Permalink
Browse files

added more files

  • Loading branch information...
1 parent d316233 commit bf8d811627bfa032fded4b2a351f8649090e980a @lefessan lefessan committed Sep 28, 2012
Showing with 7,601 additions and 54 deletions.
  1. +2 −0 .gitignore
  2. +21 −8 Makefile
  3. +0 −2 Makefile.config
  4. +6 −0 Makefile.config.in
  5. +31 −0 Readme.txt
  6. +4,806 −0 configure
  7. +45 −0 configure.ac
  8. +3 −0 docs/user-manual/Makefile
  9. +59 −0 docs/user-manual/user-manual.tex
  10. +177 −0 m4/ax_compare_version.m4
  11. +240 −0 m4/ocaml.m4
  12. +8 −0 tools/ocp-build/buildOCP.ml
  13. +3 −0 tools/ocp-build/buildOCP.mli
  14. +307 −0 tools/ocp-bytecode/byteActions.ml
  15. +38 −0 tools/ocp-bytecode/byteArgs.ml
  16. +916 −0 tools/ocp-bytecode/byteCode.ml
  17. +217 −0 tools/ocp-bytecode/byteCode.mli
  18. +314 −0 tools/ocp-bytecode/byteFile.ml
  19. +51 −0 tools/ocp-bytecode/byteFile.mli
  20. +132 −0 tools/ocp-bytecode/byteMain.ml
  21. +67 −0 tools/ocp-bytecode/byteMisc.ml
  22. +22 −0 tools/ocp-bytecode/ocp-bytecode.ocp
  23. +41 −0 tools/ocp-bytecode/strings.ml
  24. +12 −0 tools/ocp-bytecode/strings.mli
  25. +2 −0 tools/ocp-complete/ocp-complete.ocp
  26. +1 −2 tools/ocp-edit-mode/Makefile
  27. +2 −2 tools/{ocp-complete/compCandidates.ml → ocp-edit-mode/editCandidates.ml}
  28. 0 tools/{ocp-complete/compDocumentation.mli → ocp-edit-mode/editCandidates.mli}
  29. +2 −0 tools/ocp-edit-mode/editConfiguration.mlp
  30. +3 −3 tools/{ocp-complete/compDocumentation.ml → ocp-edit-mode/editDocumentation.ml}
  31. 0 tools/{ocp-complete/compCandidates.mli → ocp-edit-mode/editDocumentation.mli}
  32. +12 −12 tools/ocp-edit-mode/editEmacs.ml
  33. +2 −0 tools/ocp-edit-mode/editMain.ml
  34. +1 −1 tools/ocp-edit-mode/editOptions.ml
  35. +18 −9 tools/ocp-edit-mode/ocp-edit-mode.ocp
  36. +2 −0 tools/ocp-spotter/Readme.txt
  37. +11 −0 tools/ocp-spotter/ocp-spotter.ocp
  38. +12 −0 tools/ocp-spotter/spotfile.ml
  39. +15 −15 typerex.config → typerex.config.in
View
2 .gitignore
@@ -81,3 +81,5 @@ ocp-subst-config.exe
ocp-build/ocp-build
ocp-build/ocp-build.run
ocp-build/primitives.ml
+Makefile.config
+typerex.config
View
29 Makefile
@@ -4,6 +4,8 @@
include Makefile.config
+
+
OCPBUILD=./ocp-build/ocp-build
OCPBUILD_FLAGS=
@@ -49,14 +51,17 @@ distclean: clean $(OCPBUILD)
install:
- cp _obuild/ocp-build/ocp-build.asm $(INSTALL_PREFIX)/bin/ocp-build
- cp _obuild/ocp-fix-errors/ocp-fix-errors.asm $(INSTALL_PREFIX)/bin/ocp-fix-errors
- cp _obuild/ocp-edit-mode/ocp-edit-mode.asm $(INSTALL_PREFIX)/bin/ocp-edit-mode
- cp _obuild/ocp-complete/ocp-complete.asm $(INSTALL_PREFIX)/bin/ocp-complete
- cp _obuild/ocp-spotter/ocp-spotter.asm $(INSTALL_PREFIX)/bin/ocp-spotter
-
-install-emacs:
- cp tools/ocp-fix-errors/emacs/ocp-fix-errors.el $(HOME)/.emacs.d/
+ mkdir -p $(TYPEREXDIR)
+ mkdir -p $(BINDIR)
+ cp _obuild/ocp-build/ocp-build.asm $(BINDIR)/ocp-build
+ cp _obuild/ocp-fix-errors/ocp-fix-errors.asm $(BINDIR)/ocp-fix-errors
+ cp _obuild/ocp-edit-mode/ocp-edit-mode.asm $(BINDIR)/ocp-edit-mode
+ cp _obuild/ocp-spotter/ocp-spotter.asm $(BINDIR)/ocp-spotter
+ rm -rf $(TYPEREXDIR)/ocp-edit-mode
+ cp -dpR tools/ocp-edit-mode/files $(TYPEREXDIR)/ocp-edit-mode
+
+#install-emacs:
+# cp tools/ocp-fix-errors/emacs/ocp-fix-errors.el $(HOME)/.emacs.d/
install-manager:
sudo cp _obuild/ocaml-manager/ocaml-manager.asm /usr/bin/ocaml-manager
@@ -126,3 +131,11 @@ fabrice-upload:
git push origin fabrice-typerex
git push ocamlpro fabrice-typerex
+doc:
+ cd docs/user-manual; $(MAKE)
+
+
+
+configure: configure.ac m4/*.m4
+ aclocal -I m4
+ autoconf
View
2 Makefile.config
@@ -1,2 +0,0 @@
-INSTALL_PREFIX=/usr/local
-
View
6 Makefile.config.in
@@ -0,0 +1,6 @@
+
+DATADIR=@datarootdir@
+BINDIR=@bindir@
+LIBDIR=@libdir@
+MANDIR=@mandir@
+TYPEREXDIR=@datarootdir@/typerex
View
31 Readme.txt
@@ -0,0 +1,31 @@
+
+To build:
+---------
+
+1/ Install the sources of OCaml 4.00 as subdirectory ocaml/ocaml/
+
+ cd ocaml
+ tar zxf ~/Downloads/ocaml-4.00.0.tar.gz
+ mv ocaml-4.00.0 ocaml
+ cd ..
+
+2/ configure
+
+ ./configure -prefix /usr/local
+
+3/ Build with ocp-build. You will need to create an ocp-build.conf file in
+ the top directory.
+
+ make
+
+4/ Install
+
+ make install
+
+5/ Build and read the documentation
+
+ make doc
+ cd docs/user-manual
+ evince user-manual.pdf
+
+
View
4,806 configure
4,806 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
45 configure.ac
@@ -0,0 +1,45 @@
+AC_INIT(typerex,0.1)
+AC_COPYRIGHT(Copyright 2012 OcamlPro SAS)
+
+AC_CONFIG_MACRO_DIR([m4])
+AC_PROG_CC
+
+AC_PROG_OCAML
+if test "$OCAMLC" = "no"; then
+ AC_MSG_ERROR([You must install the OCaml compiler])
+fi
+
+AC_ARG_ENABLE(version-check,
+ [ --disable-version-check do not check OCaml version],
+ [VERSION_CHECK="$enableval"],
+ [VERSION_CHECK="yes"])
+
+# Check that OCaml version is greater or equal to 3.12.1
+if test "$VERSION_CHECK" = "yes" ; then
+ AX_COMPARE_VERSION( [$OCAMLVERSION], [lt], [3.12.1],
+ AC_MSG_ERROR([Your version of OCaml: $OCAMLVERSION is not supported]))
+fi
+
+test "x$prefix" = "xNONE" && prefix=$ac_default_prefix
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+bindir="`eval echo ${bindir}`"
+bindir="`eval echo ${bindir}`"
+mandir="`eval echo ${mandir}`"
+mandir="`eval echo ${mandir}`"
+libdir="`eval echo ${libdir}`"
+libdir="`eval echo ${libdir}`"
+datarootdir="`eval echo ${datarootdir}`"
+datarootdir="`eval echo ${datarootdir}`"
+
+AC_CONFIG_FILES(
+ Makefile.config
+ typerex.config
+)
+AC_OUTPUT
+
+echo
+echo Executables will be installed in ${bindir}
+echo Libraries will be installed in ${libdir} + typerex
+echo Data files will be installed in ${datarootdir} + typerex
+echo Manual pages will be installed in ${mandir}
View
3 docs/user-manual/Makefile
@@ -0,0 +1,3 @@
+pdf:
+ pdflatex user-manual
+ pdflatex user-manual
View
59 docs/user-manual/user-manual.tex
@@ -0,0 +1,59 @@
+\documentclass[12pt]{book}
+
+\usepackage{enumerate}
+\usepackage{color}
+\usepackage{a4wide}
+\usepackage[colorlinks=true,linkcolor=blue] {hyperref}
+\usepackage{hevea}
+\usepackage{url}
+
+\title{TypeRex user manual}
+
+\author{OCamlPro}
+\date{\today\\
+\begin{latexonly}%
+\vspace{3cm}
+\end{latexonly}%
+This manual presents the usage of \typerex, a development
+environment and toolbox for OCaml developped by OCamlPro and Inria%
+\footnote{with support from the Campus Paris Saclay fundation}.
+}
+\begin{document}
+
+\input{typerex-config.tex}
+\newcommand{\typerex}{TypeRex}
+\newcommand{\cmd}[1]{$\texttt{#1}$}
+\begin{htmlonly}
+\renewcommand{\paragraph}[1]{{\bf #1}}
+\end{htmlonly}
+
+%\newenvironment{code}{\footnotesize\verbatim}{\endverbatim}
+%\newenvironment{code}{\small\begin{verbatim}}{\end{verbatim}}
+\newcommand{\verbsize}{%BEGIN LATEX
+\footnotesize%
+%END LATEX
+%HEVEA\color{blue}
+}
+
+%BEGIN LATEX
+\maketitle
+\thispagestyle{empty}
+\cleardoublepage
+%\thispagestyle{plain}
+\input{introduction}
+\newpage
+\thispagestyle{empty}
+\tableofcontents
+%END LATEX
+
+%HEVEA\input{introduction}
+
+\chapter{TypeRex}
+
+\input{../../tools/ocp-edit-mode/docs/user-manual}
+
+\chapter{ocp-build}
+
+\input{../../tools/ocp-build/docs/user-manual}
+
+\end{document}
View
177 m4/ax_compare_version.m4
@@ -0,0 +1,177 @@
+# ===========================================================================
+# http://www.gnu.org/software/autoconf-archive/ax_compare_version.html
+# ===========================================================================
+#
+# SYNOPSIS
+#
+# AX_COMPARE_VERSION(VERSION_A, OP, VERSION_B, [ACTION-IF-TRUE], [ACTION-IF-FALSE])
+#
+# DESCRIPTION
+#
+# This macro compares two version strings. Due to the various number of
+# minor-version numbers that can exist, and the fact that string
+# comparisons are not compatible with numeric comparisons, this is not
+# necessarily trivial to do in a autoconf script. This macro makes doing
+# these comparisons easy.
+#
+# The six basic comparisons are available, as well as checking equality
+# limited to a certain number of minor-version levels.
+#
+# The operator OP determines what type of comparison to do, and can be one
+# of:
+#
+# eq - equal (test A == B)
+# ne - not equal (test A != B)
+# le - less than or equal (test A <= B)
+# ge - greater than or equal (test A >= B)
+# lt - less than (test A < B)
+# gt - greater than (test A > B)
+#
+# Additionally, the eq and ne operator can have a number after it to limit
+# the test to that number of minor versions.
+#
+# eq0 - equal up to the length of the shorter version
+# ne0 - not equal up to the length of the shorter version
+# eqN - equal up to N sub-version levels
+# neN - not equal up to N sub-version levels
+#
+# When the condition is true, shell commands ACTION-IF-TRUE are run,
+# otherwise shell commands ACTION-IF-FALSE are run. The environment
+# variable 'ax_compare_version' is always set to either 'true' or 'false'
+# as well.
+#
+# Examples:
+#
+# AX_COMPARE_VERSION([3.15.7],[lt],[3.15.8])
+# AX_COMPARE_VERSION([3.15],[lt],[3.15.8])
+#
+# would both be true.
+#
+# AX_COMPARE_VERSION([3.15.7],[eq],[3.15.8])
+# AX_COMPARE_VERSION([3.15],[gt],[3.15.8])
+#
+# would both be false.
+#
+# AX_COMPARE_VERSION([3.15.7],[eq2],[3.15.8])
+#
+# would be true because it is only comparing two minor versions.
+#
+# AX_COMPARE_VERSION([3.15.7],[eq0],[3.15])
+#
+# would be true because it is only comparing the lesser number of minor
+# versions of the two values.
+#
+# Note: The characters that separate the version numbers do not matter. An
+# empty string is the same as version 0. OP is evaluated by autoconf, not
+# configure, so must be a string, not a variable.
+#
+# The author would like to acknowledge Guido Draheim whose advice about
+# the m4_case and m4_ifvaln functions make this macro only include the
+# portions necessary to perform the specific comparison specified by the
+# OP argument in the final configure script.
+#
+# LICENSE
+#
+# Copyright (c) 2008 Tim Toolan <toolan@ele.uri.edu>
+#
+# Copying and distribution of this file, with or without modification, are
+# permitted in any medium without royalty provided the copyright notice
+# and this notice are preserved. This file is offered as-is, without any
+# warranty.
+
+#serial 11
+
+dnl #########################################################################
+AC_DEFUN([AX_COMPARE_VERSION], [
+ AC_REQUIRE([AC_PROG_AWK])
+
+ # Used to indicate true or false condition
+ ax_compare_version=false
+
+ # Convert the two version strings to be compared into a format that
+ # allows a simple string comparison. The end result is that a version
+ # string of the form 1.12.5-r617 will be converted to the form
+ # 0001001200050617. In other words, each number is zero padded to four
+ # digits, and non digits are removed.
+ AS_VAR_PUSHDEF([A],[ax_compare_version_A])
+ A=`echo "$1" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \
+ -e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/[[^0-9]]//g'`
+
+ AS_VAR_PUSHDEF([B],[ax_compare_version_B])
+ B=`echo "$3" | sed -e 's/\([[0-9]]*\)/Z\1Z/g' \
+ -e 's/Z\([[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/Z\([[0-9]][[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/Z\([[0-9]][[0-9]][[0-9]]\)Z/Z0\1Z/g' \
+ -e 's/[[^0-9]]//g'`
+
+ dnl # In the case of le, ge, lt, and gt, the strings are sorted as necessary
+ dnl # then the first line is used to determine if the condition is true.
+ dnl # The sed right after the echo is to remove any indented white space.
+ m4_case(m4_tolower($2),
+ [lt],[
+ ax_compare_version=`echo "x$A
+x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/false/;s/x${B}/true/;1q"`
+ ],
+ [gt],[
+ ax_compare_version=`echo "x$A
+x$B" | sed 's/^ *//' | sort | sed "s/x${A}/false/;s/x${B}/true/;1q"`
+ ],
+ [le],[
+ ax_compare_version=`echo "x$A
+x$B" | sed 's/^ *//' | sort | sed "s/x${A}/true/;s/x${B}/false/;1q"`
+ ],
+ [ge],[
+ ax_compare_version=`echo "x$A
+x$B" | sed 's/^ *//' | sort -r | sed "s/x${A}/true/;s/x${B}/false/;1q"`
+ ],[
+ dnl Split the operator from the subversion count if present.
+ m4_bmatch(m4_substr($2,2),
+ [0],[
+ # A count of zero means use the length of the shorter version.
+ # Determine the number of characters in A and B.
+ ax_compare_version_len_A=`echo "$A" | $AWK '{print(length)}'`
+ ax_compare_version_len_B=`echo "$B" | $AWK '{print(length)}'`
+
+ # Set A to no more than B's length and B to no more than A's length.
+ A=`echo "$A" | sed "s/\(.\{$ax_compare_version_len_B\}\).*/\1/"`
+ B=`echo "$B" | sed "s/\(.\{$ax_compare_version_len_A\}\).*/\1/"`
+ ],
+ [[0-9]+],[
+ # A count greater than zero means use only that many subversions
+ A=`echo "$A" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"`
+ B=`echo "$B" | sed "s/\(\([[0-9]]\{4\}\)\{m4_substr($2,2)\}\).*/\1/"`
+ ],
+ [.+],[
+ AC_WARNING(
+ [illegal OP numeric parameter: $2])
+ ],[])
+
+ # Pad zeros at end of numbers to make same length.
+ ax_compare_version_tmp_A="$A`echo $B | sed 's/./0/g'`"
+ B="$B`echo $A | sed 's/./0/g'`"
+ A="$ax_compare_version_tmp_A"
+
+ # Check for equality or inequality as necessary.
+ m4_case(m4_tolower(m4_substr($2,0,2)),
+ [eq],[
+ test "x$A" = "x$B" && ax_compare_version=true
+ ],
+ [ne],[
+ test "x$A" != "x$B" && ax_compare_version=true
+ ],[
+ AC_WARNING([illegal OP parameter: $2])
+ ])
+ ])
+
+ AS_VAR_POPDEF([A])dnl
+ AS_VAR_POPDEF([B])dnl
+
+ dnl # Execute ACTION-IF-TRUE / ACTION-IF-FALSE.
+ if test "$ax_compare_version" = "true" ; then
+ m4_ifvaln([$4],[$4],[:])dnl
+ m4_ifvaln([$5],[else $5])dnl
+ fi
+]) dnl AX_COMPARE_VERSION
View
240 m4/ocaml.m4
@@ -0,0 +1,240 @@
+dnl autoconf macros for OCaml
+dnl
+dnl Copyright © 2009 Richard W.M. Jones
+dnl Copyright © 2009 Stefano Zacchiroli
+dnl Copyright © 2000-2005 Olivier Andrieu
+dnl Copyright © 2000-2005 Jean-Christophe Filliâtre
+dnl Copyright © 2000-2005 Georges Mariano
+dnl
+dnl For documentation, please read the ocaml.m4 man page.
+
+AC_DEFUN([AC_PROG_OCAML],
+[dnl
+ # checking for ocamlc
+ AC_CHECK_TOOL([OCAMLC],[ocamlc],[no])
+
+ if test "$OCAMLC" != "no"; then
+ OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p'`
+ AC_MSG_RESULT([OCaml version is $OCAMLVERSION])
+ # If OCAMLLIB is set, use it
+ if test "$OCAMLLIB" = ""; then
+ OCAMLLIB=`$OCAMLC -where 2>/dev/null || $OCAMLC -v|tail -1|cut -d ' ' -f 4`
+ else
+ AC_MSG_RESULT([OCAMLLIB previously set; preserving it.])
+ fi
+ AC_MSG_RESULT([OCaml library path is $OCAMLLIB])
+
+ AC_SUBST([OCAMLVERSION])
+ AC_SUBST([OCAMLLIB])
+
+ # checking for ocamlopt
+ AC_CHECK_TOOL([OCAMLOPT],[ocamlopt],[no])
+ OCAMLBEST=byte
+ if test "$OCAMLOPT" = "no"; then
+ AC_MSG_WARN([Cannot find ocamlopt; bytecode compilation only.])
+ else
+ TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlopt discarded.])
+ OCAMLOPT=no
+ else
+ OCAMLBEST=opt
+ fi
+ fi
+
+ AC_SUBST([OCAMLBEST])
+
+ # checking for ocamlc.opt
+ AC_CHECK_TOOL([OCAMLCDOTOPT],[ocamlc.opt],[no])
+ if test "$OCAMLCDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlc.opt discarded.])
+ else
+ OCAMLC=$OCAMLCDOTOPT
+ fi
+ fi
+
+ # checking for ocamlopt.opt
+ if test "$OCAMLOPT" != "no" ; then
+ AC_CHECK_TOOL([OCAMLOPTDOTOPT],[ocamlopt.opt],[no])
+ if test "$OCAMLOPTDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([version differs from ocamlc; ocamlopt.opt discarded.])
+ else
+ OCAMLOPT=$OCAMLOPTDOTOPT
+ fi
+ fi
+ fi
+
+ AC_SUBST([OCAMLOPT])
+ fi
+
+ AC_SUBST([OCAMLC])
+
+ # checking for ocaml toplevel
+ AC_CHECK_TOOL([OCAML],[ocaml],[no])
+
+ # checking for ocamldep
+ AC_CHECK_TOOL([OCAMLDEP],[ocamldep],[no])
+
+ # checking for ocamlmktop
+ AC_CHECK_TOOL([OCAMLMKTOP],[ocamlmktop],[no])
+
+ # checking for ocamlmklib
+ AC_CHECK_TOOL([OCAMLMKLIB],[ocamlmklib],[no])
+
+ # checking for ocamldoc
+ AC_CHECK_TOOL([OCAMLDOC],[ocamldoc],[no])
+
+ # checking for ocamlbuild
+ AC_CHECK_TOOL([OCAMLBUILD],[ocamlbuild],[no])
+])
+
+
+AC_DEFUN([AC_PROG_OCAMLLEX],
+[dnl
+ # checking for ocamllex
+ AC_CHECK_TOOL([OCAMLLEX],[ocamllex],[no])
+ if test "$OCAMLLEX" != "no"; then
+ AC_CHECK_TOOL([OCAMLLEXDOTOPT],[ocamllex.opt],[no])
+ if test "$OCAMLLEXDOTOPT" != "no"; then
+ OCAMLLEX=$OCAMLLEXDOTOPT
+ fi
+ fi
+ AC_SUBST([OCAMLLEX])
+])
+
+AC_DEFUN([AC_PROG_OCAMLYACC],
+[dnl
+ AC_CHECK_TOOL([OCAMLYACC],[ocamlyacc],[no])
+ AC_SUBST([OCAMLYACC])
+])
+
+
+AC_DEFUN([AC_PROG_CAMLP4],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for camlp4
+ AC_CHECK_TOOL([CAMLP4],[camlp4],[no])
+ if test "$CAMLP4" != "no"; then
+ TMPVERSION=`$CAMLP4 -v 2>&1| sed -n -e 's|.*version *\(.*\)$|\1|p'`
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc])
+ CAMLP4=no
+ fi
+ fi
+ AC_SUBST([CAMLP4])
+
+ # checking for companion tools
+ AC_CHECK_TOOL([CAMLP4BOOT],[camlp4boot],[no])
+ AC_CHECK_TOOL([CAMLP4O],[camlp4o],[no])
+ AC_CHECK_TOOL([CAMLP4OF],[camlp4of],[no])
+ AC_CHECK_TOOL([CAMLP4OOF],[camlp4oof],[no])
+ AC_CHECK_TOOL([CAMLP4ORF],[camlp4orf],[no])
+ AC_CHECK_TOOL([CAMLP4PROF],[camlp4prof],[no])
+ AC_CHECK_TOOL([CAMLP4R],[camlp4r],[no])
+ AC_CHECK_TOOL([CAMLP4RF],[camlp4rf],[no])
+ AC_SUBST([CAMLP4BOOT])
+ AC_SUBST([CAMLP4O])
+ AC_SUBST([CAMLP4OF])
+ AC_SUBST([CAMLP4OOF])
+ AC_SUBST([CAMLP4ORF])
+ AC_SUBST([CAMLP4PROF])
+ AC_SUBST([CAMLP4R])
+ AC_SUBST([CAMLP4RF])
+])
+
+
+AC_DEFUN([AC_PROG_FINDLIB],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for ocamlfind
+ AC_CHECK_TOOL([OCAMLFIND],[ocamlfind],[no])
+ AC_SUBST([OCAMLFIND])
+])
+
+
+dnl Thanks to Jim Meyering for working this next bit out for us.
+dnl XXX We should define AS_TR_SH if it's not defined already
+dnl (eg. for old autoconf).
+AC_DEFUN([AC_CHECK_OCAML_PKG],
+[dnl
+ AC_REQUIRE([AC_PROG_FINDLIB])dnl
+
+ AC_MSG_CHECKING([for OCaml findlib package $1])
+
+ unset found
+ unset pkg
+ found=no
+ for pkg in $1 $2 ; do
+ if $OCAMLFIND query $pkg >/dev/null 2>/dev/null; then
+ AC_MSG_RESULT([found])
+ AS_TR_SH([OCAML_PKG_$1])=$pkg
+ found=yes
+ break
+ fi
+ done
+ if test "$found" = "no" ; then
+ AC_MSG_RESULT([not found])
+ AS_TR_SH([OCAML_PKG_$1])=no
+ fi
+
+ AC_SUBST(AS_TR_SH([OCAML_PKG_$1]))
+])
+
+
+AC_DEFUN([AC_CHECK_OCAML_MODULE],
+[dnl
+ AC_MSG_CHECKING([for OCaml module $2])
+
+ cat > conftest.ml <<EOF
+open $3
+EOF
+ unset found
+ for $1 in $$1 $4 ; do
+ if $OCAMLC -c -I "$$1" conftest.ml >&5 2>&5 ; then
+ found=yes
+ break
+ fi
+ done
+
+ if test "$found" ; then
+ AC_MSG_RESULT([$$1])
+ else
+ AC_MSG_RESULT([not found])
+ $1=no
+ fi
+ AC_SUBST([$1])
+])
+
+
+dnl XXX Cross-compiling
+AC_DEFUN([AC_CHECK_OCAML_WORD_SIZE],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+ AC_MSG_CHECKING([for OCaml compiler word size])
+ cat > conftest.ml <<EOF
+ print_endline (string_of_int Sys.word_size)
+ EOF
+ OCAML_WORD_SIZE=`$OCAML conftest.ml`
+ AC_MSG_RESULT([$OCAML_WORD_SIZE])
+ AC_SUBST([OCAML_WORD_SIZE])
+])
+
+AC_DEFUN([AC_CHECK_OCAML_OS_TYPE],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+ AC_MSG_CHECKING([OCaml Sys.os_type])
+
+ cat > conftest.ml <<EOF
+ print_string(Sys.os_type);;
+EOF
+
+ OCAML_OS_TYPE=`$OCAML conftest.ml`
+ AC_MSG_RESULT([$OCAML_OS_TYPE])
+ AC_SUBST([OCAML_OS_TYPE])
+])
View
8 tools/ocp-build/buildOCP.ml
@@ -444,3 +444,11 @@ let find_package pj file =
) pj.project_sorted;
!list
+
+let rec find_obuild f dir =
+ let possible_dir = Filename.concat dir "_obuild" in
+ if Sys.file_exists possible_dir then
+ f possible_dir
+ else
+ let new_dir = Filename.dirname dir in
+ if dir <> new_dir then find_obuild f new_dir
View
3 tools/ocp-build/buildOCP.mli
@@ -30,3 +30,6 @@ val find_package : project -> File.t -> package list
val save_project_state : project -> File.t -> unit
val load_project_state : File.t -> project
+
+val find_obuild : (string -> unit) -> string -> unit
+
View
307 tools/ocp-bytecode/byteActions.ml
@@ -0,0 +1,307 @@
+
+(* "Expunge" a toplevel by removing compiler modules from the global List.map.
+ Usage: expunge <source file> <dest file> <names of modules to keep> *)
+
+open Sys
+open Misc
+open ByteArgs
+open ByteMisc
+
+module StringSet =
+ Set.Make(struct
+ type t = string
+ let compare = compare
+ end)
+
+let flush_action () =
+ match !current_action with
+ None -> ()
+ | Some (set, action) ->
+ current_action := None;
+ action !set
+
+let set_action action =
+ flush_action ();
+ current_action := Some (ref [], action)
+
+let get_file () =
+ match !current_file with
+ None ->
+ Printf.fprintf stderr "Error: first argument must be the name of the file to load\n%!";
+ exit 2
+ | Some (filename, t) -> (filename, t)
+
+(* from bytecomp/symtable *)
+let filter_global_map p (n,s) =
+ let newtbl = ref Tbl.empty in
+ Tbl.iter
+ (fun id num -> if p id then newtbl := Tbl.add id num !newtbl)
+ s;
+ (n, !newtbl)
+
+let expunge modules =
+ let to_keep = ref StringSet.empty in
+
+ let expunge_map tbl =
+ filter_global_map
+ (fun id -> StringSet.mem (Ident.name id) !to_keep)
+ tbl
+ in
+ let expunge_crcs tbl =
+ List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl
+ in
+ Array.iter
+ (fun exn -> to_keep := StringSet.add exn !to_keep)
+ Runtimedef.builtin_exceptions;
+ List.iter (fun name ->
+ to_keep := StringSet.add (String.capitalize name) !to_keep
+ ) modules;
+
+ let (filename, t) = get_file () in
+
+ let (nsymbols, symbols) = expunge_map (t.ByteFile.nsymbols, t.ByteFile.symbols) in
+ let imports = expunge_crcs t.ByteFile.imports in
+
+ t.ByteFile.imports <- imports;
+ t.ByteFile.nsymbols <- nsymbols;
+ t.ByteFile.symbols <- symbols
+
+let load_primitives input_name =
+ let prims = ref [] in
+ let ic = open_in input_name in
+ try
+ while true do
+ let line = input_line ic in
+ prims := line :: !prims
+ done;
+ assert false
+ with End_of_file ->
+ close_in ic;
+ Array.of_list (List.rev !prims)
+
+(*
+
+let print_primitives () =
+ StringSet.iter (fun s ->
+ Printf.fprintf stderr "%s\n" s
+ ) !used_prims;
+ Printf.fprintf stderr "%!"
+
+let primitive_table = ref [||]
+
+let keep_primitives input_name =
+ let t = ByteFile.load input_name in
+ let filter_prims prims =
+ Array.map (fun prim ->
+ if StringSet.mem prim !used_prims then
+ prim
+ else begin
+ Printf.fprintf stderr "Removing primitive %s\n" prim;
+ "caml_sys_exit"
+ end
+ ) prims
+ in
+ let new_t = { t with ByteFile.primitives = filter_prims t.ByteFile.primitives } in
+ ByteFile.save !target_arg new_t;
+ exit 0
+
+let load_used_primitives filename =
+ let t = ByteFile.load filename in
+ let module IterUsedPrimitives = ByteCode.IterPrimitives(struct
+ let unit (_,prim) = use_prim t.ByteFile.primitives.(prim) end) in
+ ByteCode.iter (fun _ opcode -> IterUsedPrimitives.unit opcode) t;
+ ()
+
+let load_primitives_table filename =
+ let t = ByteFile.load filename in
+ Array.iter use_prim t.ByteFile.primitives
+
+*)
+
+
+let remove_primitives prim_filename =
+ let (filename,t) = get_file () in
+ let primitives = load_primitives prim_filename in
+ let removed_prims = ref StringSet.empty in
+ let remove_prim s =
+ if not (StringSet.mem s !removed_prims) then
+ removed_prims := StringSet.add s !removed_prims
+ in
+ Array.iter remove_prim primitives;
+
+ let filter_prims prims =
+ Array.map (fun prim ->
+ if not ( StringSet.mem prim !removed_prims ) then
+ prim
+ else begin
+ Printf.fprintf stderr "Removing primitive %s\n" prim;
+ "caml_sys_exit"
+ end
+ ) prims
+ in
+ t.ByteFile.primitives <- filter_prims t.ByteFile.primitives
+
+
+let filter_unused_primitives () =
+ let (filename,t) = get_file () in
+ let used_prims = ref StringSet.empty in
+ let use_prim s =
+ if not (StringSet.mem s !used_prims) then
+ used_prims := StringSet.add s !used_prims
+ in
+
+ let module IterUsedPrimitives = ByteCode.IterPrimitives(struct
+ let unit (_,prim) = use_prim t.ByteFile.primitives.(prim) end) in
+ ByteCode.iter (fun _ opcode -> IterUsedPrimitives.unit opcode) t;
+
+ let filter_prims prims =
+ Array.map (fun prim ->
+ if StringSet.mem prim !used_prims then
+ prim
+ else begin
+ Printf.fprintf stderr "Removing primitive %s\n" prim;
+ "caml_sys_exit"
+ end
+ ) prims
+ in
+ t.ByteFile.primitives <- filter_prims t.ByteFile.primitives
+
+
+
+let set_primitive_table primitive_table =
+ let (filename,t) = get_file () in
+ let prim_map = ref StringMap.empty in
+ Array.iteri (fun i prim ->
+ prim_map := StringMap.add prim i !prim_map
+ ) primitive_table;
+
+ let module IterPrimitives = ByteCode.IterPrimitives(struct
+ let unit (pos,prim) =
+ let prim = t.ByteFile.primitives.(prim) in
+ let new_pos = StringMap.find prim !prim_map in
+ LittleEndian.str_uint t.ByteFile.code pos new_pos
+ end) in
+ ByteCode.iter (fun _ opcode -> IterPrimitives.unit opcode) t;
+ t.ByteFile.primitives <- primitive_table
+
+(*
+
+let strip_sections input_name =
+ Printf.fprintf stderr "Warning: beware that this will only work if the CODE section is not\n";
+ Printf.fprintf stderr " moved by removing other sections\n";
+ let raw = ByteFile.RAW.load input_name in
+ let rec filter_sections list =
+ match list with
+ [] -> []
+ | (name, content) :: tail
+ when List.mem name !anon_args ->
+ Printf.fprintf stderr "Removing section %s of size %d\n%!" name (String.length content);
+ filter_sections tail
+ | head :: tail -> head :: (filter_sections tail)
+ in
+ let new_raw = { raw with ByteFile.RAW.sections = filter_sections raw.ByteFile.RAW.sections } in
+ Printf.fprintf stderr "Saving to file %s\n%!" !target_arg;
+ ByteFile.RAW.save !target_arg new_raw;
+ exit 0
+*)
+
+let set_primitives prim_filename =
+ set_primitive_table (load_primitives prim_filename)
+
+let save_primitives output_filename =
+ let (filename, t) = get_file () in
+ let oc = open_out output_filename in
+ Array.iter (fun prim -> Printf.fprintf oc "%s\n" prim) t.ByteFile.primitives;
+ close_out oc
+
+let print_primitives () =
+ let (filename, t) = get_file () in
+ Array.iter (fun prim -> Printf.printf "%s\n" prim) t.ByteFile.primitives;
+ Printf.printf "%!"
+
+let make_static () =
+ let (filename, t) = get_file () in
+ t.ByteFile.dll_path <- [];
+ t.ByteFile.dll_names <- [];
+ current_file := Some (filename, t)
+
+let list_sections () =
+ let (filename, t) = get_file () in
+ let raw = t.ByteFile.raw in
+ Printf.printf "File %s\n" filename;
+ let header_len = String.length raw.ByteFile.RAW.header in
+ Printf.printf "Header: %d bytes\n" header_len;
+ let rec iter pos sections =
+ match sections with
+ [] -> ()
+ | (name, content) :: tail ->
+ let len = String.length content in
+ Printf.printf "Section %s at pos %d len %d\n"
+ name pos len;
+ iter (pos+len) tail
+ in
+ iter header_len raw.ByteFile.RAW.sections;
+ Printf.printf "%!";
+ ()
+
+let dump () =
+ let (filename, t) = get_file () in
+ Printf.printf "File %s\n" filename;
+ let s = ByteFile.string_of_file t in
+ Printf.printf "%s\n%!" s;
+ ()
+
+module IntSet = Set.Make (struct type t = int let compare = compare end)
+
+let disass () =
+ let (filename, t) = get_file () in
+ Printf.printf "File %s\n" filename;
+
+ let labels = ref IntSet.empty in
+ let module GetLabels = ByteCode.IterDisp(struct
+ let unit l = labels := IntSet.add l !labels
+ end) in
+ ByteCode.iter (fun pos opcode -> GetLabels.unit opcode) t;
+
+
+ let label_names = ref IntMap.empty in
+ let counter = ref 0 in
+ IntSet.iter (fun l ->
+ incr counter;
+ label_names := IntMap.add l !counter !label_names) !labels;
+
+ let globals = ref IntMap.empty in
+ Tbl.iter (fun name pos ->
+ globals := IntMap.add pos (Ident.name name) !globals
+ ) t.ByteFile.symbols;
+
+ let module Printer = ByteCode.Printer(struct
+ module Disp = struct
+ let to_string t = Printf.sprintf "L%d" (IntMap.find t !label_names)
+ end
+
+ module Global = struct
+ let to_string t = try
+ IntMap.find t !globals
+ with Not_found -> string_of_int t
+ end
+
+ module Primitive = struct
+ let to_string (_, prim) =
+ t.ByteFile.primitives.(prim)
+
+ end
+ end) in
+
+ let label_name l =
+ try
+ Printf.sprintf "L%d" (IntMap.find l !label_names)
+ with Not_found ->
+ ""
+ in
+
+ ByteCode.iter (fun pos opcode ->
+ Printf.printf "%s\t%d\t%s\n"
+ (label_name pos) pos (Printer.string_of_opcode opcode)
+ ) t;
+ Printf.printf "%!";
View
38 tools/ocp-bytecode/byteArgs.ml
@@ -0,0 +1,38 @@
+
+(* "Expunge" a toplevel by removing compiler modules from the global List.map.
+ Usage: expunge <source file> <dest file> <names of modules to keep> *)
+
+open Sys
+open Misc
+
+(*
+let target_arg = ref "a.out"
+let anon_args = ref ([] : string list)
+
+type action =
+ Dump
+ | Expunge of string
+ | KeepPrimitives of string
+ | StripSections of string
+ | ListSections of string
+ | Disass
+ | PrintPrims of string
+ | PrintUsedPrims of string
+ | SetPrimitiveTable of string
+ | PrintLoadedPrims
+(* | DumpSection of string *)
+
+let main_action = ref (None : (string * action) option)
+
+let set_main_action name action =
+ match !main_action with
+ None -> main_action := Some (name, action)
+ | Some (old_name, _) ->
+ Printf.fprintf stderr "You cannot specify both actions %s and %s\n%!"
+ old_name name;
+ exit 2
+*)
+
+let current_file = ref (None : (string * ByteFile.t) option)
+let current_action = ref (None : ( (string list ref) * (string list -> unit) ) option)
+let must_save = ref false
View
916 tools/ocp-bytecode/byteCode.ml
@@ -0,0 +1,916 @@
+open ByteMisc
+
+module Uint = struct
+ type t = int
+ let get s pos = LittleEndian.get_uint s pos, pos + 4
+end
+
+module Sint = struct
+ type t = int
+ let get s pos = LittleEndian.get_sint s pos, pos + 4
+end
+
+module Disp = struct
+ type t = int
+ let get s pos = pos / 4 + LittleEndian.get_sint s pos, pos + 4
+end
+
+let string_of_intarray t =
+ String.concat ", " (Array.to_list (Array.map string_of_int (t)))
+
+module Closurerec = struct
+ type t =
+ int (* nfuncs *)
+ * int (* nvars *)
+ * int array
+
+ let get s pos =
+ let nfuncs = LittleEndian.get_uint s pos in
+ let nvars = LittleEndian.get_uint s (pos+4) in
+ let orig = pos + 8 in
+ let funcs = Array.init nfuncs (fun i ->
+ orig/4 + LittleEndian.get_sint s (orig + i * 4)
+ ) in
+ (nfuncs, nvars, funcs), orig + 4 * nfuncs
+
+ let to_string (nfuncs, nvars, funcs) =
+ Printf.sprintf "{nfuncs=%d, nvars=%d, funcs=[%s]}"
+ nfuncs nvars (string_of_intarray funcs)
+
+end
+
+module Global = struct
+ type t = int
+ let get s pos = LittleEndian.get_uint s pos, pos + 4
+end
+
+module Switch = struct
+ type t = int array * int array
+
+ let get s pos =
+ let n = LittleEndian.get_uint s pos in
+ let orig = pos + 4 in
+ let pc = orig / 4 in
+ let nconsts = n land 0xFFFF in
+ let t1 = Array.init nconsts (fun i ->
+ pc + LittleEndian.get_sint s (orig + i * 4)
+ ) in
+ let n_nonconsts = n lsr 16 in
+ let orig = orig + nconsts * 4 in
+ let t2 = Array.init n_nonconsts (fun i ->
+ pc + LittleEndian.get_sint s (orig + i * 4)
+ ) in
+ let orig = orig + n_nonconsts * 4 in
+ (t1, t2), orig
+
+ let to_string (t1, t2) =
+ Printf.sprintf "{ consts = [%s]; non_consts = [%s] }"
+ (string_of_intarray t1)
+ (string_of_intarray t2)
+end
+
+module Primitive = struct
+ type t = int * int
+ let get s pos = (pos, LittleEndian.get_uint s pos), pos + 4
+end
+
+module Pubmet = struct
+ type t = int
+ let get s pos =
+ let tag = LittleEndian.get_sint s pos in
+ let _cache = LittleEndian.get_uint s (pos+4) in
+ tag, pos+8
+end
+
+type opcode =
+ | ACC0
+ | ACC1
+ | ACC2
+ | ACC3
+ | ACC4
+ | ACC5
+ | ACC6
+ | ACC7
+ | ACC of Uint.t
+ | PUSH
+ | PUSHACC0
+ | PUSHACC1
+ | PUSHACC2
+ | PUSHACC3
+ | PUSHACC4
+ | PUSHACC5
+ | PUSHACC6
+ | PUSHACC7
+ | PUSHACC of Uint.t
+ | POP of Uint.t
+ | ASSIGN of Uint.t
+ | ENVACC1
+ | ENVACC2
+ | ENVACC3
+ | ENVACC4
+ | ENVACC of Uint.t
+ | PUSHENVACC1
+ | PUSHENVACC2
+ | PUSHENVACC3
+ | PUSHENVACC4
+ | PUSHENVACC of Uint.t
+ | PUSH_RETADDR of Disp.t
+ | APPLY of Uint.t
+ | APPLY1
+ | APPLY2
+ | APPLY3
+ | APPTERM of Uint.t * Uint.t
+ | APPTERM1 of Uint.t
+ | APPTERM2 of Uint.t
+ | APPTERM3 of Uint.t
+ | RETURN of Uint.t
+ | RESTART
+ | GRAB of Uint.t
+ | CLOSURE of Uint.t * Disp.t
+ | CLOSUREREC of Closurerec.t
+ | OFFSETCLOSUREM2
+ | OFFSETCLOSURE0
+ | OFFSETCLOSURE2
+ | OFFSETCLOSURE of Sint.t (* was Uint *)
+ | PUSHOFFSETCLOSUREM2
+ | PUSHOFFSETCLOSURE0
+ | PUSHOFFSETCLOSURE2
+ | PUSHOFFSETCLOSURE of Sint.t (* was Nothing *)
+ | GETGLOBAL of Global.t
+ | PUSHGETGLOBAL of Global.t
+ | GETGLOBALFIELD of Global.t * Uint.t
+ | PUSHGETGLOBALFIELD of Global.t * Uint.t
+ | SETGLOBAL of Global.t
+ | ATOM0
+ | ATOM of Uint.t
+ | PUSHATOM0
+ | PUSHATOM of Uint.t
+ | MAKEBLOCK of Uint.t * Uint.t
+ | MAKEBLOCK1 of Uint.t
+ | MAKEBLOCK2 of Uint.t
+ | MAKEBLOCK3 of Uint.t
+ | MAKEFLOATBLOCK of Uint.t
+ | GETFIELD0
+ | GETFIELD1
+ | GETFIELD2
+ | GETFIELD3
+ | GETFIELD of Uint.t
+ | GETFLOATFIELD of Uint.t
+ | SETFIELD0
+ | SETFIELD1
+ | SETFIELD2
+ | SETFIELD3
+ | SETFIELD of Uint.t
+ | SETFLOATFIELD of Uint.t
+ | VECTLENGTH
+ | GETVECTITEM
+ | SETVECTITEM
+ | GETSTRINGCHAR
+ | SETSTRINGCHAR
+ | BRANCH of Disp.t
+ | BRANCHIF of Disp.t
+ | BRANCHIFNOT of Disp.t
+ | SWITCH of Switch.t
+ | BOOLNOT
+ | PUSHTRAP of Disp.t
+ | POPTRAP
+ | RAISE
+ | CHECK_SIGNALS
+ | C_CALL1 of Primitive.t
+ | C_CALL2 of Primitive.t
+ | C_CALL3 of Primitive.t
+ | C_CALL4 of Primitive.t
+ | C_CALL5 of Primitive.t
+ | C_CALLN of Uint.t * Primitive.t
+ | CONST0
+ | CONST1
+ | CONST2
+ | CONST3
+ | CONSTINT of Sint.t
+ | PUSHCONST0
+ | PUSHCONST1
+ | PUSHCONST2
+ | PUSHCONST3
+ | PUSHCONSTINT of Sint.t
+ | NEGINT
+ | ADDINT
+ | SUBINT
+ | MULINT
+ | DIVINT
+ | MODINT
+ | ANDINT
+ | ORINT
+ | XORINT
+ | LSLINT
+ | LSRINT
+ | ASRINT
+ | EQ
+ | NEQ
+ | LTINT
+ | LEINT
+ | GTINT
+ | GEINT
+ | OFFSETINT of Sint.t
+ | OFFSETREF of Sint.t
+ | ISINT
+ | GETMETHOD
+ | GETDYNMET
+ | GETPUBMET of Pubmet.t
+ | BEQ of Sint.t * Disp.t
+ | BNEQ of Sint.t * Disp.t
+ | BLTINT of Sint.t * Disp.t
+ | BLEINT of Sint.t * Disp.t
+ | BGTINT of Sint.t * Disp.t
+ | BGEINT of Sint.t * Disp.t
+ | ULTINT
+ | UGEINT
+ | BULTINT of Uint.t * Disp.t
+ | BUGEINT of Uint.t * Disp.t
+ | STOP
+ | EVENT
+ | BREAK
+
+
+let opcodes = [|
+ (fun s pos -> ACC0, pos);
+ (fun s pos -> ACC1, pos);
+ (fun s pos -> ACC2, pos);
+ (fun s pos -> ACC3, pos);
+ (fun s pos -> ACC4, pos);
+ (fun s pos -> ACC5, pos);
+ (fun s pos -> ACC6, pos);
+ (fun s pos -> ACC7, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ ACC n, pos);
+ (fun s pos -> PUSH, pos);
+ (fun s pos -> PUSHACC0, pos);
+ (fun s pos -> PUSHACC1, pos);
+ (fun s pos -> PUSHACC2, pos);
+ (fun s pos -> PUSHACC3, pos);
+ (fun s pos -> PUSHACC4, pos);
+ (fun s pos -> PUSHACC5, pos);
+ (fun s pos -> PUSHACC6, pos);
+ (fun s pos -> PUSHACC7, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ PUSHACC n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ POP n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ ASSIGN n, pos);
+ (fun s pos -> ENVACC1, pos);
+ (fun s pos -> ENVACC2, pos);
+ (fun s pos -> ENVACC3, pos);
+ (fun s pos -> ENVACC4, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ ENVACC n, pos);
+ (fun s pos -> PUSHENVACC1, pos);
+ (fun s pos -> PUSHENVACC2, pos);
+ (fun s pos -> PUSHENVACC3, pos);
+ (fun s pos -> PUSHENVACC4, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ PUSHENVACC n, pos);
+ (fun s pos ->
+ let (n,pos) = Disp.get s pos in
+ PUSH_RETADDR n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ APPLY n, pos);
+ (fun s pos -> APPLY1, pos);
+ (fun s pos -> APPLY2, pos);
+ (fun s pos -> APPLY3, pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Uint.get s pos in
+ APPTERM (n1, n2), pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ APPTERM1 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ APPTERM2 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ APPTERM3 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ RETURN n, pos);
+ (fun s pos -> RESTART, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ GRAB n, pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ CLOSURE (n1,n2), pos);
+ (fun s pos ->
+ let (n,pos) = Closurerec.get s pos in
+ CLOSUREREC n, pos);
+ (fun s pos -> OFFSETCLOSUREM2, pos);
+ (fun s pos -> OFFSETCLOSURE0, pos);
+ (fun s pos -> OFFSETCLOSURE2, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ OFFSETCLOSURE n, pos);
+ (fun s pos -> PUSHOFFSETCLOSUREM2, pos);
+ (fun s pos -> PUSHOFFSETCLOSURE0, pos);
+ (fun s pos -> PUSHOFFSETCLOSURE2, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ PUSHOFFSETCLOSURE n, pos);
+ (fun s pos ->
+ let (n,pos) = Global.get s pos in
+ GETGLOBAL n, pos);
+ (fun s pos ->
+ let (n,pos) = Global.get s pos in
+ PUSHGETGLOBAL n, pos);
+ (fun s pos ->
+ let (n1,pos) = Global.get s pos in
+ let (n2,pos) = Uint.get s pos in
+ GETGLOBALFIELD (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Global.get s pos in
+ let (n2,pos) = Uint.get s pos in
+ PUSHGETGLOBALFIELD (n1,n2), pos);
+ (fun s pos ->
+ let (n,pos) = Global.get s pos in
+ SETGLOBAL n, pos);
+ (fun s pos -> ATOM0, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ ATOM n, pos);
+ (fun s pos -> PUSHATOM0, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ PUSHATOM n, pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Uint.get s pos in
+ MAKEBLOCK (n1,n2), pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ MAKEBLOCK1 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ MAKEBLOCK2 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ MAKEBLOCK3 n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ MAKEFLOATBLOCK n, pos);
+ (fun s pos -> GETFIELD0, pos);
+ (fun s pos -> GETFIELD1, pos);
+ (fun s pos -> GETFIELD2, pos);
+ (fun s pos -> GETFIELD3, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ GETFIELD n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ GETFLOATFIELD n, pos);
+ (fun s pos -> SETFIELD0, pos);
+ (fun s pos -> SETFIELD1, pos);
+ (fun s pos -> SETFIELD2, pos);
+ (fun s pos -> SETFIELD3, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ SETFIELD n, pos);
+ (fun s pos ->
+ let (n,pos) = Uint.get s pos in
+ SETFLOATFIELD n, pos);
+ (fun s pos -> VECTLENGTH, pos);
+ (fun s pos -> GETVECTITEM, pos);
+ (fun s pos -> SETVECTITEM, pos);
+ (fun s pos -> GETSTRINGCHAR, pos);
+ (fun s pos -> SETSTRINGCHAR, pos);
+ (fun s pos ->
+ let (n,pos) = Disp.get s pos in
+ BRANCH n, pos);
+ (fun s pos ->
+ let (n,pos) = Disp.get s pos in
+ BRANCHIF n, pos);
+ (fun s pos ->
+ let (n,pos) = Disp.get s pos in
+ BRANCHIFNOT n, pos);
+ (fun s pos ->
+ let (n,pos) = Switch.get s pos in
+ SWITCH n, pos);
+ (fun s pos -> BOOLNOT, pos);
+ (fun s pos ->
+ let (n,pos) = Disp.get s pos in
+ PUSHTRAP n, pos);
+ (fun s pos -> POPTRAP, pos);
+ (fun s pos -> RAISE, pos);
+ (fun s pos -> CHECK_SIGNALS, pos);
+ (fun s pos ->
+ let (n,pos) = Primitive.get s pos in
+ C_CALL1 n, pos);
+ (fun s pos ->
+ let (n,pos) = Primitive.get s pos in
+ C_CALL2 n, pos);
+ (fun s pos ->
+ let (n,pos) = Primitive.get s pos in
+ C_CALL3 n, pos);
+ (fun s pos ->
+ let (n,pos) = Primitive.get s pos in
+ C_CALL4 n, pos);
+ (fun s pos ->
+ let (n,pos) = Primitive.get s pos in
+ C_CALL5 n, pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Primitive.get s pos in
+ C_CALLN (n1,n2), pos);
+ (fun s pos -> CONST0, pos);
+ (fun s pos -> CONST1, pos);
+ (fun s pos -> CONST2, pos);
+ (fun s pos -> CONST3, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ CONSTINT n, pos);
+ (fun s pos -> PUSHCONST0, pos);
+ (fun s pos -> PUSHCONST1, pos);
+ (fun s pos -> PUSHCONST2, pos);
+ (fun s pos -> PUSHCONST3, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ PUSHCONSTINT n, pos);
+ (fun s pos -> NEGINT, pos);
+ (fun s pos -> ADDINT, pos);
+ (fun s pos -> SUBINT, pos);
+ (fun s pos -> MULINT, pos);
+ (fun s pos -> DIVINT, pos);
+ (fun s pos -> MODINT, pos);
+ (fun s pos -> ANDINT, pos);
+ (fun s pos -> ORINT, pos);
+ (fun s pos -> XORINT, pos);
+ (fun s pos -> LSLINT, pos);
+ (fun s pos -> LSRINT, pos);
+ (fun s pos -> ASRINT, pos);
+ (fun s pos -> EQ, pos);
+ (fun s pos -> NEQ, pos);
+ (fun s pos -> LTINT, pos);
+ (fun s pos -> LEINT, pos);
+ (fun s pos -> GTINT, pos);
+ (fun s pos -> GEINT, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ OFFSETINT n, pos);
+ (fun s pos ->
+ let (n,pos) = Sint.get s pos in
+ OFFSETREF n, pos);
+ (fun s pos -> ISINT, pos);
+ (fun s pos -> GETMETHOD, pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BEQ (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BNEQ (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BLTINT (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BLEINT (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BGTINT (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Sint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BGEINT (n1,n2), pos);
+ (fun s pos -> ULTINT, pos);
+ (fun s pos -> UGEINT, pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BULTINT (n1,n2), pos);
+ (fun s pos ->
+ let (n1,pos) = Uint.get s pos in
+ let (n2,pos) = Disp.get s pos in
+ BUGEINT (n1,n2), pos);
+ (fun s pos ->
+ let (n,pos) = Pubmet.get s pos in
+ GETPUBMET n, pos);
+ (fun s pos -> GETDYNMET, pos);
+ (fun s pos -> STOP, pos);
+ (fun s pos -> EVENT, pos);
+ (fun s pos -> BREAK, pos);
+ |]
+
+
+let iter f t =
+ let rec iter f code begin_pos =
+ if begin_pos < String.length code then
+ let op = LittleEndian.get_uint code begin_pos in
+ let pos = begin_pos + 4 in
+ let opcode, end_pos = opcodes.(op) code pos in
+ f (begin_pos/4) opcode;
+ iter f code end_pos
+ in
+ iter f t.ByteFile.code 0
+
+
+module Printer( PrinterArg :
+ sig
+ module Disp : sig val to_string : int -> string end
+ module Global : sig val to_string : int -> string end
+ module Primitive : sig val to_string : int*int -> string end
+ end
+) = struct
+
+ open PrinterArg
+
+ let string_of_disparray t =
+ String.concat ", " (Array.to_list (Array.map Disp.to_string (t)))
+
+ module Closurerec = struct
+
+ let to_string (nfuncs, nvars, funcs) =
+ Printf.sprintf "{nfuncs=%d, nvars=%d, funcs=[%s]}"
+ nfuncs nvars (string_of_disparray funcs)
+ end
+
+ module Switch = struct
+
+ let to_string (t1, t2) =
+ Printf.sprintf "{ consts = [%s]; non_consts = [%s] }"
+ (string_of_disparray t1)
+ (string_of_disparray t2)
+ end
+
+ let string_of_opcode op =
+ match op with
+ | ACC0 -> "ACC0"
+ | ACC1 -> "ACC1"
+ | ACC2 -> "ACC2"
+ | ACC3 -> "ACC3"
+ | ACC4 -> "ACC4"
+ | ACC5 -> "ACC5"
+ | ACC6 -> "ACC6"
+ | ACC7 -> "ACC7"
+ | ACC (uint_t) -> Printf.sprintf "ACC (%d)" uint_t
+ | PUSH -> "PUSH"
+ | PUSHACC0 -> "PUSHACC0"
+ | PUSHACC1 -> "PUSHACC1"
+ | PUSHACC2 -> "PUSHACC2"
+ | PUSHACC3 -> "PUSHACC3"
+ | PUSHACC4 -> "PUSHACC4"
+ | PUSHACC5 -> "PUSHACC5"
+ | PUSHACC6 -> "PUSHACC6"
+ | PUSHACC7 -> "PUSHACC7"
+ | PUSHACC (uint_t) -> Printf.sprintf "PUSHACC (%d)" uint_t
+ | POP (uint_t) -> Printf.sprintf "POP (%d)" uint_t
+ | ASSIGN (uint_t) -> Printf.sprintf "ASSIGN (%d)" uint_t
+ | ENVACC1 -> "ENVACC1"
+ | ENVACC2 -> "ENVACC2"
+ | ENVACC3 -> "ENVACC3"
+ | ENVACC4 -> "ENVACC4"
+ | ENVACC (uint_t) -> Printf.sprintf "ENVACC (%d)" uint_t
+ | PUSHENVACC1 -> "PUSHENVACC1"
+ | PUSHENVACC2 -> "PUSHENVACC2"
+ | PUSHENVACC3 -> "PUSHENVACC3"
+ | PUSHENVACC4 -> "PUSHENVACC4"
+ | PUSHENVACC (uint_t) -> Printf.sprintf "PUSHENVACC (%d)" uint_t
+ | PUSH_RETADDR (disp_t) -> Printf.sprintf "PUSH_RETADDR (%s)" (Disp.to_string disp_t)
+ | APPLY (uint_t) -> Printf.sprintf "APPLY (%d)" uint_t
+ | APPLY1 -> "APPLY1"
+ | APPLY2 -> "APPLY2"
+ | APPLY3 -> "APPLY3"
+ | APPTERM (uint1, uint2) -> Printf.sprintf "APPTERM (%d, %d)" uint1 uint2
+ | APPTERM1 (uint_t) -> Printf.sprintf "APPTERM1 (%d)" uint_t
+ | APPTERM2 (uint_t) -> Printf.sprintf "APPTERM2 (%d)" uint_t
+ | APPTERM3 (uint_t) -> Printf.sprintf "APPTERM3 (%d)" uint_t
+ | RETURN (uint_t) -> Printf.sprintf "RETURN (%d)" uint_t
+ | RESTART -> "RESTART"
+ | GRAB (uint_t) -> Printf.sprintf "GRAB (%d)" uint_t
+ | CLOSURE (uint_t, disp_t) -> Printf.sprintf "CLOSURE (%d,%s)" uint_t (Disp.to_string disp_t)
+ | CLOSUREREC (closurerec_t) -> Printf.sprintf "CLOSUREREC (%s)"
+ (Closurerec.to_string closurerec_t)
+ | OFFSETCLOSUREM2 -> "OFFSETCLOSUREM2"
+ | OFFSETCLOSURE0 -> "OFFSETCLOSURE0"
+ | OFFSETCLOSURE2 -> "OFFSETCLOSURE2"
+ | OFFSETCLOSURE (sint_t) -> Printf.sprintf "OFFSETCLOSURE (%d)" sint_t
+ | PUSHOFFSETCLOSUREM2 -> "PUSHOFFSETCLOSUREM2"
+ | PUSHOFFSETCLOSURE0 -> "PUSHOFFSETCLOSURE0"
+ | PUSHOFFSETCLOSURE2 -> "PUSHOFFSETCLOSURE2"
+ | PUSHOFFSETCLOSURE (sint_t) -> Printf.sprintf "PUSHOFFSETCLOSURE (%d)" sint_t
+ | GETGLOBAL (global_t) -> Printf.sprintf "GETGLOBAL (%s)" (Global.to_string global_t)
+ | PUSHGETGLOBAL (global_t) -> Printf.sprintf "PUSHGETGLOBAL (%s)" (Global.to_string global_t)
+ | GETGLOBALFIELD (global_t, uint_t) -> Printf.sprintf "GETGLOBALFIELD (%s,%d)" (Global.to_string global_t) uint_t
+ | PUSHGETGLOBALFIELD (global_t, uint_t) -> Printf.sprintf "PUSHGETGLOBALFIELD (%s,%d)" (Global.to_string global_t) uint_t
+ | SETGLOBAL (global_t) -> Printf.sprintf "SETGLOBAL (%s)" (Global.to_string global_t)
+ | ATOM0 -> "ATOM0"
+ | ATOM (uint_t) -> Printf.sprintf "ATOM (%d)" uint_t
+ | PUSHATOM0 -> "PUSHATOM0"
+ | PUSHATOM (uint_t) -> Printf.sprintf "PUSHATOM (%d)" uint_t
+ | MAKEBLOCK (uint_t1, uint_t2) -> Printf.sprintf "MAKEBLOCK (%d,%d)" uint_t1 uint_t2
+ | MAKEBLOCK1 (uint_t) -> Printf.sprintf "MAKEBLOCK1 (%d)" uint_t
+ | MAKEBLOCK2 (uint_t) -> Printf.sprintf "MAKEBLOCK2 (%d)" uint_t
+ | MAKEBLOCK3 (uint_t) -> Printf.sprintf "MAKEBLOCK3 (%d)" uint_t
+ | MAKEFLOATBLOCK (uint_t) -> Printf.sprintf "MAKEFLOATBLOCK (%d)" uint_t
+ | GETFIELD0 -> "GETFIELD0"
+ | GETFIELD1 -> "GETFIELD1"
+ | GETFIELD2 -> "GETFIELD2"
+ | GETFIELD3 -> "GETFIELD3"
+ | GETFIELD (uint_t) -> Printf.sprintf "GETFIELD (%d)" uint_t
+ | GETFLOATFIELD (uint_t) -> Printf.sprintf "GETFLOATFIELD (%d)" uint_t
+ | SETFIELD0 -> "SETFIELD0"
+ | SETFIELD1 -> "SETFIELD1"
+ | SETFIELD2 -> "SETFIELD2"
+ | SETFIELD3 -> "SETFIELD3"
+ | SETFIELD (uint_t) -> Printf.sprintf "SETFIELD (%d)" uint_t
+ | SETFLOATFIELD (uint_t) -> Printf.sprintf "SETFLOATFIELD (%d)" uint_t
+ | VECTLENGTH -> "VECTLENGTH"
+ | GETVECTITEM -> "GETVECTITEM"
+ | SETVECTITEM -> "SETVECTITEM"
+ | GETSTRINGCHAR -> "GETSTRINGCHAR"
+ | SETSTRINGCHAR -> "SETSTRINGCHAR"
+ | BRANCH (disp_t) -> Printf.sprintf "BRANCH (%s)" (Disp.to_string disp_t)
+ | BRANCHIF (disp_t) -> Printf.sprintf "BRANCHIF (%s)" (Disp.to_string disp_t)
+ | BRANCHIFNOT (disp_t) -> Printf.sprintf "BRANCHIFNOT (%s)" (Disp.to_string disp_t)
+ | SWITCH (switch_t) -> Printf.sprintf "SWITCH (%s)" (Switch.to_string switch_t)
+ | BOOLNOT -> "BOOLNOT"
+ | PUSHTRAP (disp_t) -> Printf.sprintf "PUSHTRAP (%s)" (Disp.to_string disp_t)
+ | POPTRAP -> "POPTRAP"
+ | RAISE -> "RAISE"
+ | CHECK_SIGNALS -> "CHECK_SIGNALS"
+ | C_CALL1 (primitive_t) -> Printf.sprintf "C_CALL1 (%s)" (Primitive.to_string primitive_t)
+ | C_CALL2 (primitive_t) -> Printf.sprintf "C_CALL2 (%s)" (Primitive.to_string primitive_t)
+ | C_CALL3 (primitive_t) -> Printf.sprintf "C_CALL3 (%s)" (Primitive.to_string primitive_t)
+ | C_CALL4 (primitive_t) -> Printf.sprintf "C_CALL4 (%s)" (Primitive.to_string primitive_t)
+ | C_CALL5 (primitive_t) -> Printf.sprintf "C_CALL5 (%s)" (Primitive.to_string primitive_t)
+ | C_CALLN (uint_t, primitive_t) -> Printf.sprintf "C_CALLN (%d,%s)" uint_t (Primitive.to_string primitive_t)
+ | CONST0 -> "CONST0"
+ | CONST1 -> "CONST1"
+ | CONST2 -> "CONST2"
+ | CONST3 -> "CONST3"
+ | CONSTINT (sint_t) -> Printf.sprintf "CONSTINT (%d)" sint_t
+ | PUSHCONST0 -> "PUSHCONST0"
+ | PUSHCONST1 -> "PUSHCONST1"
+ | PUSHCONST2 -> "PUSHCONST2"
+ | PUSHCONST3 -> "PUSHCONST3"
+ | PUSHCONSTINT (sint_t) -> Printf.sprintf "PUSHCONSTINT (%d)" sint_t
+ | NEGINT -> "NEGINT"
+ | ADDINT -> "ADDINT"
+ | SUBINT -> "SUBINT"
+ | MULINT -> "MULINT"
+ | DIVINT -> "DIVINT"
+ | MODINT -> "MODINT"
+ | ANDINT -> "ANDINT"
+ | ORINT -> "ORINT"
+ | XORINT -> "XORINT"
+ | LSLINT -> "LSLINT"
+ | LSRINT -> "LSRINT"
+ | ASRINT -> "ASRINT"
+ | EQ -> "EQ"
+ | NEQ -> "NEQ"
+ | LTINT -> "LTINT"
+ | LEINT -> "LEINT"
+ | GTINT -> "GTINT"
+ | GEINT -> "GEINT"
+ | OFFSETINT (sint_t) -> Printf.sprintf "OFFSETINT (%d)" sint_t
+ | OFFSETREF (sint_t) -> Printf.sprintf "OFFSETREF (%d)" sint_t
+ | ISINT -> "ISINT"
+ | GETMETHOD -> "GETMETHOD"
+ | GETDYNMET -> "GETDYNMET"
+ | GETPUBMET (pubmet_t) -> Printf.sprintf "GETPUBMET (%d)" pubmet_t
+ | BEQ (sint_t, disp_t) -> Printf.sprintf "BEQ (%d,%s)" sint_t (Disp.to_string disp_t)
+ | BNEQ (sint_t, disp_t) -> Printf.sprintf "BNEQ (%d,%s)" sint_t (Disp.to_string disp_t)
+ | BLTINT (sint_t, disp_t) -> Printf.sprintf "BLTINT (%d,%s)" sint_t (Disp.to_string disp_t)
+ | BLEINT (sint_t, disp_t) -> Printf.sprintf "BLEINT (%d,%s)" sint_t (Disp.to_string disp_t)
+ | BGTINT (sint_t, disp_t) -> Printf.sprintf "BGTINT (%d,%s)" sint_t (Disp.to_string disp_t)
+ | BGEINT (sint_t, disp_t) -> Printf.sprintf "BGEINT (%d,%s)" sint_t (Disp.to_string disp_t)
+ | ULTINT -> "ULTINT"
+ | UGEINT -> "UGEINT"
+ | BULTINT (uint_t, disp_t) -> Printf.sprintf "BULTINT (%d,%s)" uint_t (Disp.to_string disp_t)
+ | BUGEINT (uint_t, disp_t) -> Printf.sprintf "BUGEINT (%d,%s)" uint_t (Disp.to_string disp_t)
+ | STOP -> "STOP"
+ | EVENT -> "EVENT"
+ | BREAK -> "BREAK"
+
+end
+
+module RAW = Printer(struct
+ module Disp = struct
+ let to_string t = string_of_int t
+ end
+
+ module Global = struct
+ let to_string t = string_of_int t
+ end
+
+ module Primitive = struct
+ let to_string (_, t) = string_of_int t
+ end
+end)
+
+
+module Iterator( IteratorArg :
+ sig
+ module Disp : sig val unit : int -> unit end
+ module Global : sig val unit : int -> unit end
+ module Primitive : sig val unit : int*int -> unit end
+ end
+) = struct
+
+ open IteratorArg
+
+ module Closurerec = struct
+ let unit (_, _, funcs) = Array.iter Disp.unit funcs
+ end
+ module Switch = struct
+ let unit (t1,t2) =
+ Array.iter Disp.unit t1;
+ Array.iter Disp.unit t2
+ end
+
+
+ let unit op =
+ match op with
+ | ACC0 -> ()
+ | ACC1 -> ()
+ | ACC2 -> ()
+ | ACC3 -> ()
+ | ACC4 -> ()
+ | ACC5 -> ()
+ | ACC6 -> ()
+ | ACC7 -> ()
+ | ACC (uint_t) -> ()
+ | PUSH -> ()
+ | PUSHACC0 -> ()
+ | PUSHACC1 -> ()
+ | PUSHACC2 -> ()
+ | PUSHACC3 -> ()
+ | PUSHACC4 -> ()
+ | PUSHACC5 -> ()
+ | PUSHACC6 -> ()
+ | PUSHACC7 -> ()
+ | PUSHACC (uint_t) -> ()
+ | POP (uint_t) -> ()
+ | ASSIGN (uint_t) -> ()
+ | ENVACC1 -> ()
+ | ENVACC2 -> ()
+ | ENVACC3 -> ()
+ | ENVACC4 -> ()
+ | ENVACC (uint_t) -> ()
+ | PUSHENVACC1 -> ()
+ | PUSHENVACC2 -> ()
+ | PUSHENVACC3 -> ()
+ | PUSHENVACC4 -> ()
+ | PUSHENVACC (uint_t) -> ()
+ | PUSH_RETADDR (disp_t) -> Disp.unit disp_t
+ | APPLY (uint_t) -> ()
+ | APPLY1 -> ()
+ | APPLY2 -> ()
+ | APPLY3 -> ()
+ | APPTERM (uint1, uint2) -> ()
+ | APPTERM1 (uint_t) -> ()
+ | APPTERM2 (uint_t) -> ()
+ | APPTERM3 (uint_t) -> ()
+ | RETURN (uint_t) -> ()
+ | RESTART -> ()
+ | GRAB (uint_t) -> ()
+ | CLOSURE (uint_t, disp_t) -> Disp.unit disp_t
+ | CLOSUREREC (closurerec_t) -> Closurerec.unit closurerec_t
+ | OFFSETCLOSUREM2 -> ()
+ | OFFSETCLOSURE0 -> ()
+ | OFFSETCLOSURE2 -> ()
+ | OFFSETCLOSURE (sint_t) -> ()
+ | PUSHOFFSETCLOSUREM2 -> ()
+ | PUSHOFFSETCLOSURE0 -> ()
+ | PUSHOFFSETCLOSURE2 -> ()
+ | PUSHOFFSETCLOSURE (sint_t) -> ()
+ | GETGLOBAL (global_t) -> Global.unit global_t
+ | PUSHGETGLOBAL (global_t) -> Global.unit global_t
+ | GETGLOBALFIELD (global_t, uint_t) -> Global.unit global_t
+ | PUSHGETGLOBALFIELD (global_t, uint_t) -> Global.unit global_t
+ | SETGLOBAL (global_t) -> Global.unit global_t
+ | ATOM0 -> ()
+ | ATOM (uint_t) -> ()
+ | PUSHATOM0 -> ()
+ | PUSHATOM (uint_t) -> ()
+ | MAKEBLOCK (uint_t1, uint_t2) -> ()
+ | MAKEBLOCK1 (uint_t) -> ()
+ | MAKEBLOCK2 (uint_t) -> ()
+ | MAKEBLOCK3 (uint_t) -> ()
+ | MAKEFLOATBLOCK (uint_t) -> ()
+ | GETFIELD0 -> ()
+ | GETFIELD1 -> ()
+ | GETFIELD2 -> ()
+ | GETFIELD3 -> ()
+ | GETFIELD (uint_t) -> ()
+ | GETFLOATFIELD (uint_t) -> ()
+ | SETFIELD0 -> ()
+ | SETFIELD1 -> ()
+ | SETFIELD2 -> ()
+ | SETFIELD3 -> ()
+ | SETFIELD (uint_t) -> ()
+ | SETFLOATFIELD (uint_t) -> ()
+ | VECTLENGTH -> ()
+ | GETVECTITEM -> ()
+ | SETVECTITEM -> ()
+ | GETSTRINGCHAR -> ()
+ | SETSTRINGCHAR -> ()
+ | BRANCH (disp_t) -> Disp.unit disp_t
+ | BRANCHIF (disp_t) -> Disp.unit disp_t
+ | BRANCHIFNOT (disp_t) -> Disp.unit disp_t
+ | SWITCH (switch_t) -> Switch.unit switch_t
+ | BOOLNOT -> ()
+ | PUSHTRAP (disp_t) -> Disp.unit disp_t
+ | POPTRAP -> ()
+ | RAISE -> ()
+ | CHECK_SIGNALS -> ()
+ | C_CALL1 (primitive_t) -> Primitive.unit primitive_t
+ | C_CALL2 (primitive_t) -> Primitive.unit primitive_t
+ | C_CALL3 (primitive_t) -> Primitive.unit primitive_t
+ | C_CALL4 (primitive_t) -> Primitive.unit primitive_t
+ | C_CALL5 (primitive_t) -> Primitive.unit primitive_t
+ | C_CALLN (uint_t, primitive_t) -> Primitive.unit primitive_t
+ | CONST0 -> ()
+ | CONST1 -> ()
+ | CONST2 -> ()
+ | CONST3 -> ()
+ | CONSTINT (sint_t) -> ()
+ | PUSHCONST0 -> ()
+ | PUSHCONST1 -> ()
+ | PUSHCONST2 -> ()
+ | PUSHCONST3 -> ()
+ | PUSHCONSTINT (sint_t) -> ()
+ | NEGINT -> ()
+ | ADDINT -> ()
+ | SUBINT -> ()
+ | MULINT -> ()
+ | DIVINT -> ()
+ | MODINT -> ()
+ | ANDINT -> ()
+ | ORINT -> ()
+ | XORINT -> ()
+ | LSLINT -> ()
+ | LSRINT -> ()
+ | ASRINT -> ()
+ | EQ -> ()
+ | NEQ -> ()
+ | LTINT -> ()
+ | LEINT -> ()
+ | GTINT -> ()
+ | GEINT -> ()
+ | OFFSETINT (sint_t) -> ()
+ | OFFSETREF (sint_t) -> ()
+ | ISINT -> ()
+ | GETMETHOD -> ()
+ | GETDYNMET -> ()
+ | GETPUBMET (pubmet_t) -> ()
+ | BEQ (sint_t, disp_t) -> Disp.unit disp_t
+ | BNEQ (sint_t, disp_t) -> Disp.unit disp_t
+ | BLTINT (sint_t, disp_t) -> Disp.unit disp_t
+ | BLEINT (sint_t, disp_t) -> Disp.unit disp_t
+ | BGTINT (sint_t, disp_t) -> Disp.unit disp_t
+ | BGEINT (sint_t, disp_t) -> Disp.unit disp_t
+ | ULTINT -> ()
+ | UGEINT -> ()
+ | BULTINT (uint_t, disp_t) -> Disp.unit disp_t
+ | BUGEINT (uint_t, disp_t) -> Disp.unit disp_t
+ | STOP -> ()
+ | EVENT -> ()
+ | BREAK -> ()
+
+end
+
+module UnitNothing = struct let unit _ = () end
+
+module IterPrimitives(M: sig
+ val unit : Primitive.t -> unit
+end) = Iterator(struct
+ module Disp = UnitNothing
+ module Global = UnitNothing
+ module Primitive = M
+end)
+
+module IterGlobals(M: sig
+ val unit : Global.t -> unit
+end) = Iterator(struct
+ module Disp = UnitNothing
+ module Global = M
+ module Primitive = UnitNothing
+end)
+
+module IterDisp(M: sig
+ val unit : int -> unit
+end) = Iterator(struct
+ module Disp = M
+ module Global = UnitNothing
+ module Primitive = UnitNothing
+end)
View
217 tools/ocp-bytecode/byteCode.mli
@@ -0,0 +1,217 @@
+
+module Uint : sig type t = int end
+
+module Sint : sig type t = int end
+
+module Disp : sig type t = int end
+
+module Closurerec : sig
+ type t =
+ int (* nfuncs *)
+ * int (* nvars *)
+ * int array
+end
+
+module Global : sig type t = int end
+
+module Switch : sig
+ type t = int array * int array
+end
+
+module Primitive : sig
+ type t = int * int (* position * primitive_number *)
+end
+
+module Pubmet : sig type t = int end
+
+type opcode =
+ | ACC0
+ | ACC1
+ | ACC2
+ | ACC3
+ | ACC4
+ | ACC5
+ | ACC6
+ | ACC7
+ | ACC of Uint.t
+ | PUSH
+ | PUSHACC0
+ | PUSHACC1
+ | PUSHACC2
+ | PUSHACC3
+ | PUSHACC4
+ | PUSHACC5
+ | PUSHACC6
+ | PUSHACC7
+ | PUSHACC of Uint.t
+ | POP of Uint.t
+ | ASSIGN of Uint.t
+ | ENVACC1
+ | ENVACC2
+ | ENVACC3
+ | ENVACC4
+ | ENVACC of Uint.t
+ | PUSHENVACC1
+ | PUSHENVACC2
+ | PUSHENVACC3
+ | PUSHENVACC4
+ | PUSHENVACC of Uint.t
+ | PUSH_RETADDR of Disp.t
+ | APPLY of Uint.t
+ | APPLY1
+ | APPLY2
+ | APPLY3
+ | APPTERM of Uint.t * Uint.t
+ | APPTERM1 of Uint.t
+ | APPTERM2 of Uint.t
+ | APPTERM3 of Uint.t
+ | RETURN of Uint.t
+ | RESTART
+ | GRAB of Uint.t
+ | CLOSURE of Uint.t * Disp.t
+ | CLOSUREREC of Closurerec.t
+ | OFFSETCLOSUREM2
+ | OFFSETCLOSURE0
+ | OFFSETCLOSURE2
+ | OFFSETCLOSURE of Sint.t (* was Uint *)
+ | PUSHOFFSETCLOSUREM2
+ | PUSHOFFSETCLOSURE0
+ | PUSHOFFSETCLOSURE2
+ | PUSHOFFSETCLOSURE of Sint.t (* was Nothing *)
+ | GETGLOBAL of Global.t
+ | PUSHGETGLOBAL of Global.t
+ | GETGLOBALFIELD of Global.t * Uint.t
+ | PUSHGETGLOBALFIELD of Global.t * Uint.t
+ | SETGLOBAL of Global.t
+ | ATOM0
+ | ATOM of Uint.t
+ | PUSHATOM0
+ | PUSHATOM of Uint.t
+ | MAKEBLOCK of Uint.t * Uint.t
+ | MAKEBLOCK1 of Uint.t
+ | MAKEBLOCK2 of Uint.t
+ | MAKEBLOCK3 of Uint.t
+ | MAKEFLOATBLOCK of Uint.t
+ | GETFIELD0
+ | GETFIELD1
+ | GETFIELD2
+ | GETFIELD3
+ | GETFIELD of Uint.t
+ | GETFLOATFIELD of Uint.t
+ | SETFIELD0
+ | SETFIELD1
+ | SETFIELD2
+ | SETFIELD3
+ | SETFIELD of Uint.t
+ | SETFLOATFIELD of Uint.t
+ | VECTLENGTH
+ | GETVECTITEM
+ | SETVECTITEM
+ | GETSTRINGCHAR
+ | SETSTRINGCHAR
+ | BRANCH of Disp.t
+ | BRANCHIF of Disp.t
+ | BRANCHIFNOT of Disp.t
+ | SWITCH of Switch.t
+ | BOOLNOT
+ | PUSHTRAP of Disp.t
+ | POPTRAP
+ | RAISE
+ | CHECK_SIGNALS
+ | C_CALL1 of Primitive.t
+ | C_CALL2 of Primitive.t
+ | C_CALL3 of Primitive.t
+ | C_CALL4 of Primitive.t
+ | C_CALL5 of Primitive.t
+ | C_CALLN of Uint.t * Primitive.t
+ | CONST0
+ | CONST1
+ | CONST2
+ | CONST3
+ | CONSTINT of Sint.t
+ | PUSHCONST0
+ | PUSHCONST1
+ | PUSHCONST2
+ | PUSHCONST3
+ | PUSHCONSTINT of Sint.t
+ | NEGINT
+ | ADDINT
+ | SUBINT
+ | MULINT
+ | DIVINT
+ | MODINT
+ | ANDINT
+ | ORINT
+ | XORINT
+ | LSLINT
+ | LSRINT
+ | ASRINT
+ | EQ
+ | NEQ
+ | LTINT
+ | LEINT
+ | GTINT
+ | GEINT
+ | OFFSETINT of Sint.t
+ | OFFSETREF of Sint.t
+ | ISINT
+ | GETMETHOD
+ | GETDYNMET
+ | GETPUBMET of Pubmet.t
+ | BEQ of Sint.t * Disp.t
+ | BNEQ of Sint.t * Disp.t
+ | BLTINT of Sint.t * Disp.t
+ | BLEINT of Sint.t * Disp.t
+ | BGTINT of Sint.t * Disp.t
+ | BGEINT of Sint.t * Disp.t
+ | ULTINT
+ | UGEINT
+ | BULTINT of Uint.t * Disp.t
+ | BUGEINT of Uint.t * Disp.t
+ | STOP
+ | EVENT
+ | BREAK
+
+val iter : (int -> (* position / 4 *)
+ opcode -> (* opcode at that position *)
+ unit) -> ByteFile.t -> unit
+
+module RAW : sig
+ val string_of_opcode : opcode -> string
+end
+
+module Printer :
+ functor
+ (PrinterArg : sig
+ module Disp :
+ sig val to_string : Disp.t -> string end
+ module Global :
+ sig val to_string : Global.t -> string end
+ module Primitive :
+ sig val to_string : Primitive.t -> string end
+ end) ->
+ sig val string_of_opcode : opcode -> string end
+
+module Iterator : functor
+ (IteratorArg : sig
+ module Disp : sig val unit : Disp.t -> unit end
+ module Global : sig val unit : Global.t -> unit end
+ module Primitive : sig val unit : Primitive.t -> unit end
+ end) ->
+ sig val unit : opcode -> unit end
+
+module IterDisp :
+ functor (M : sig val unit : Disp.t -> unit end) ->
+ sig
+ val unit : opcode -> unit
+ end
+module IterGlobals :
+ functor (M : sig val unit : Global.t -> unit end) ->
+ sig
+ val unit : opcode -> unit
+ end
+module IterPrimitives :
+ functor (M : sig val unit : Primitive.t -> unit end) ->
+ sig
+ val unit : opcode -> unit
+ end
View
314 tools/ocp-bytecode/byteFile.ml
@@ -0,0 +1,314 @@
+(* Copyright: OCamlPro *)
+(* Author: Fabrice LE FESSANT (OCamlPro) *)
+
+
+(*
+Sections are:
+ RNTM: the executable code of the runtime
+ CODE: the bytecode
+ DLPT: path to dynamic libraries
+ DLLS: dynamic libraries
+ PRIM: primitive table (output_value: )
+ DATA: global table (output_value: )
+ SYMB: symbol table (output_value: )
+ CRCS: checksums (output_value: )
+ DBUG: debug info (output_value: )
+*)
+
+open ByteMisc
+
+type error =
+ FileTooShort
+ | BadMagic of string (* what was read *)
+
+exception Error of
+ string (* filename *)
+ * error (* the error *)
+
+let exec_magic_number = "Caml1999X008"
+
+module RAW : sig
+
+ type t = {
+ header : string;
+ sections : (string * string) list;
+ magic : string;
+ }
+ val load : string -> t
+ val save : string -> t -> unit
+ val is_bytecode_executable : string -> bool
+
+end = struct
+
+type t = {
+ header : string;
+ sections : (string * string) list;
+ magic : string;
+}
+
+let is_bytecode_executable filename =
+ let ic = open_in_bin filename in
+ try
+ let length = in_channel_length ic in
+ let magic = exec_magic_number in
+ let len_magic = String.length magic in
+ if len_magic + 4 > length then raise Not_found;
+ let buffer = String.create len_magic in
+ let pos_magic = length - len_magic in
+ seek_in ic pos_magic;
+ really_input ic buffer 0 len_magic;
+ close_in ic;
+ buffer = magic
+ with e ->
+ close_in ic;
+ Printf.fprintf stderr "is_bytecode_executable %s: false (%s)\n%!" filename
+ (Printexc.to_string e);
+ false
+
+let load filename =
+ let ic = open_in_bin filename in
+ try
+ let length = in_channel_length ic in
+ let magic = exec_magic_number in
+ let len_magic = String.length magic in
+ if len_magic + 4 > length then
+ raise (Error (filename, FileTooShort));
+ let buffer = String.create len_magic in
+ let pos_magic = length - len_magic in
+ seek_in ic pos_magic;
+ really_input ic buffer 0 len_magic;
+ if buffer <> magic then
+ raise (Error (filename, BadMagic buffer));
+ let pos_nsections = pos_magic - 4 in
+ seek_in ic pos_nsections;
+ let nsections = input_binary_int ic in
+ let pos_table = pos_nsections - 8 * nsections in
+ if pos_table < 0 then
+ raise (Error (filename, FileTooShort));
+ seek_in ic pos_table;
+ let sections = ref [] in
+ let total_size = ref 0 in
+ for i = 1 to nsections do
+ let name = String.create 4 in
+ really_input ic name 0 4;
+ let len = input_binary_int ic in
+ sections := (name, len) :: !sections;
+ total_size := !total_size + len;
+ done;
+ let len_trailer = 8 * nsections + 4 + len_magic in
+ let trailer = String.create len_trailer in
+ seek_in ic pos_table;
+ really_input ic trailer 0 len_trailer;
+ let rec read_sections end_pos table sections =
+ match table with
+ [] -> sections
+ | (name, len) :: tail ->
+ let begin_pos = end_pos - len in
+ let content = String.create len in
+ seek_in ic begin_pos;
+ really_input ic content 0 len;
+ read_sections begin_pos tail ( (name, content) :: sections )
+ in
+ let sections = read_sections pos_table !sections [] in
+ let pos_sections = pos_table - !total_size in
+ let header = String.create pos_sections in
+ if pos_sections > 0 then begin
+ seek_in ic 0;
+ really_input ic header 0 pos_sections;
+ end;
+ close_in ic;
+ {
+ header = header;
+ sections = sections;
+ magic = magic;
+ }
+ with e -> close_in ic ; raise e
+
+let save filename t =
+ let oc =
+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
+ filename in
+ output_string oc t.header;
+ List.iter (fun (name, content) ->
+ output_string oc content;
+ ) t.sections;
+ List.iter (fun (name, content) ->
+ output_string oc name;
+ output_binary_int oc (String.length content);
+ ) t.sections;
+ output_binary_int oc (List.length t.sections);
+ output_string oc t.magic;
+ close_out oc
+
+end
+
+type t = {
+ header : string;
+ mutable primitives : string array;
+ mutable data : Obj.t array;
+ mutable nsymbols : int;
+ mutable symbols : (Ident.t, int) Tbl.t;
+ mutable debug : (int * Instruct.debug_event list) list;
+ mutable code : string;
+ mutable dll_path : string list;
+ mutable dll_names : string list;
+ mutable imports : (string * Digest.t) list;
+ mutable runtime : string option;
+ mutable other_sections : (string * string) list;
+
+ magic : string;
+
+ raw : RAW.t; (* Cannot be modified *)
+}
+
+(* copied from bytecomp/bytesections.ml *)
+let read_stringlist p =
+ let len = String.length p 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
+ split 0 0
+
+let read_primitive_table p = Array.of_list(read_stringlist p)
+
+let load filename =
+ let raw = RAW.load filename in
+ let t = {