Repository: pirapira/bamboo Branch: master Commit: 1cca98e0b6d2 Files: 162 Total size: 710.1 KB Directory structure: gitextract_oes_fca_/ ├── .gitignore ├── .gitmodules ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── ReleaseNotes.txt ├── __tests__/ │ └── compare-js-native.js ├── _oasis ├── _tags ├── bsconfig.json ├── doc/ │ ├── manifest.md │ ├── semantics.md │ ├── spec.tex │ ├── testing-bytecode.md │ └── tutorial.md ├── myocamlbuild.ml ├── opam/ │ ├── descr │ └── opam ├── package.json ├── setup.ml ├── sketch/ │ ├── future.bbo │ └── open_auction.bbo └── src/ ├── ast/ │ ├── META │ ├── ast.mldylib │ ├── ast.mllib │ ├── ast_test.ml │ ├── contract.ml │ ├── contract.mli │ ├── ethereum.ml │ ├── ethereum.mli │ ├── evm.ml │ ├── evm.mli │ ├── location.ml │ ├── location.mli │ ├── pseudoImm.ml │ ├── pseudoImm.mli │ ├── sideEffect.ml │ ├── sideEffect.mli │ ├── syntax.ml │ ├── syntax.mli │ ├── type.ml │ ├── type.mli │ ├── typeEnv.ml │ └── typeEnv.mli ├── basics/ │ ├── META │ ├── assoc.ml │ ├── assoc.mli │ ├── basics.mldylib │ ├── basics.mllib │ ├── hex_test.ml │ ├── hexa.ml │ ├── hexa.mli │ ├── label.ml │ ├── label.mli │ ├── misc.ml │ ├── misc.mli │ ├── storage.ml │ └── storage.mli ├── codegen/ │ ├── META │ ├── codegen.ml │ ├── codegen.mldylib │ ├── codegen.mli │ ├── codegen.mllib │ ├── codegenEnv.ml │ ├── codegenEnv.mli │ ├── codegen_test.ml │ ├── codegen_test2.ml │ ├── entrypointDatabase.ml │ ├── entrypointDatabase.mli │ ├── layoutInfo.ml │ ├── layoutInfo.mli │ ├── layouts.txt │ ├── locationEnv.ml │ ├── locationEnv.mli │ ├── parse.ml │ └── parse.mli ├── cross-platform/ │ ├── META │ ├── cross-platform.mldylib │ ├── cross-platform.mllib │ ├── rope.ml │ ├── wrapBn.ml │ ├── wrapBnNative.ml │ ├── wrapCryptokit.ml │ ├── wrapCryptokitNative.ml │ ├── wrapList.ml │ ├── wrapListNative.ml │ ├── wrapOption.ml │ ├── wrapString.ml │ └── wrapStringNative.ml ├── cross-platform-for-ocamlbuild/ │ ├── META │ ├── cross-platform.mldylib │ ├── cross-platform.mllib │ └── wrapOption.ml ├── exec/ │ ├── bamboo.ml │ ├── compileFile.ml │ ├── compileFile.mli │ └── endToEnd.ml ├── exec-js/ │ └── bambooJs.ml ├── lib/ │ ├── META │ └── lib_test.ml ├── parse/ │ ├── META │ ├── README.md │ ├── examples/ │ │ ├── 000nil.bbo │ │ ├── 001empty.bbo │ │ ├── 002comment.bbo │ │ ├── 003default_abort.bbo │ │ ├── 004simple_case_abort.bbo │ │ ├── 005auction_start.bbo │ │ ├── 006auction_first_case.bbo │ │ ├── 007auction_first_case_more.bbo │ │ ├── 008new_var.bbo │ │ ├── 009new_var_auc.bbo │ │ ├── 00a_auc_first_cast.bbo │ │ ├── 00b_auction_more.bbo │ │ ├── 00bbauction_first_named_case.bbo │ │ ├── 00c_auction.bbo │ │ ├── 00d_auction.bbo │ │ ├── 00e_ecdsarecover.bbo │ │ ├── 00f_bytes32.bbo │ │ ├── 00g_int8.bbo │ │ ├── 00h_payment_channel.bbo │ │ ├── 00i_local_bool.bbo │ │ ├── 010_logical_and.bbo │ │ ├── 011_keccak256.bbo │ │ ├── 013_iszero.bbo │ │ ├── 014_ifelse.bbo │ │ ├── 015_ifblock.bbo │ │ ├── 016_void.bbo │ │ ├── 017_return_void.bbo │ │ ├── 018_mapmap.bbo │ │ ├── 019_something.bbo │ │ ├── 01a_event.bbo │ │ ├── 01b_erc20better.bbo │ │ ├── 020_plus_mult.bbo │ │ ├── 021_land_neq.bbo │ │ ├── 022_plus_gt.bbo │ │ ├── 024_vault.bbo │ │ ├── 024_vault_shorter.bbo │ │ ├── 025_declit_numeric.bbo │ │ ├── 026_abc.bbo │ │ └── 027_counting.bbo │ ├── lexer.mll │ ├── negative_examples/ │ │ ├── bad_end.bbo │ │ ├── duplicate_contract_names.bbo │ │ ├── mixed_uints.bbo │ │ ├── multi_default.bbo │ │ ├── uint256_too_big.bbo │ │ ├── uint8_too_big.bbo │ │ ├── uint8_with_four_digits.bbo │ │ ├── unknown_ctor_arg.bbo │ │ ├── unknown_return.bbo │ │ ├── unknown_type.bbo │ │ ├── void_not_void.bbo │ │ ├── void_some_return.bbo │ │ ├── wrong_arg.bbo │ │ └── wrong_return.bbo │ ├── parse.mldylib │ ├── parse.mllib │ ├── parser.mly │ └── parser_test.ml └── run_tests.sh ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ *~ *.native _build setup.data setup.log .DS_Store .merlin .bsb.lock npm-debug.log /lib/bs/ /lib/js/ /node_modules/ src/parse/lexer.ml src/parse/parser.ml ================================================ FILE: .gitmodules ================================================ [submodule "bamboo-tests"] path = bamboo-tests url = https://github.com/pirapira/bamboo-tests.git ================================================ FILE: .travis.yml ================================================ notifications: webhooks: urls: - https://webhooks.gitter.im/e/4f71b9fa80e108068016 on_success: change # options: [always|never|change] default: always on_failure: always # options: [always|never|change] default: always on_start: never # options: [always|never|change] default: always dist: trusty cache: directories: - $HOME/.ccache - $HOME/build/pirapira/cpp-ethereum - $HOME/build/pirapira/cmake env: global: - CASHER_TIME_OUT=1200 sudo: required before_install: - BAMBOO=`pwd` - sudo apt-get -qq update - sudo apt-get install aspcud ccache jq # - git clone https://github.com/polyml/polyml.git # - cd polyml # - git checkout v5.6 # - ./configure # - make # - make compiler # - sudo make install # - cd - # - sudo updatedb # - locate libpolymain.a - wget https://raw.github.com/ocaml/opam/master/shell/opam_installer.sh -O - | sudo sh -s /usr/local/bin - export OPAMJOBS=2 - opam init -y --comp=4.02.3+buckle-master - opam switch 4.02.3+buckle-master - eval `opam config env` - opam update - opam upgrade -y # It's important to install batteries first, so the proper version of rpc can be installed afterwards - git clone https://github.com/bsansouci/batteries-included - cd ./batteries-included && opam pin add -y batteries . && cd .. - opam install -y ocamlfind menhir rope zarith ppx_deriving rpc=1.9.52 cryptokit hex - cd ../.. - if [ ! -d cpp-ethereum/.git ]; then rm -rf cpp-ethereum; git clone https://github.com/pirapira/cpp-ethereum --recursive; fi - sudo apt install -y build-essential libgmp-dev libleveldb-dev libmicrohttpd-dev g++-4.8 gcc-4.8 - sudo apt purge -y cmake - mkdir -p cmake - cd cmake - if [ ! -f cmake-3.8.2-Linux-x86_64.tar.gz ]; then wget https://cmake.org/files/v3.8/cmake-3.8.2-Linux-x86_64.tar.gz && tar xf cmake-3.8.2-Linux-x86_64.tar.gz; fi - PATH=`pwd`/cmake-3.8.2-Linux-x86_64/bin:$PATH - cd - - cmake --version - cd cpp-ethereum - git fetch - git checkout origin/test-raw-sign - git show | head -n 3 - git submodule update --recursive - mkdir -p build - cd build - CC=gcc-4.8 CXX=g++-4.8 cmake .. - CC=gcc-4.8 CXX=g++-4.8 make -j3 eth - sudo make install - cd $BAMBOO - sudo apt install texlive-latex-base texlive-science texlive-math-extra install: - npm install - cd bamboo-tests - npm install - cd - script: - make doc/spec.pdf - make - ln -s ./bamboo.native lib/bs/native/bamboo - PATH=`pwd`/lib/bs/native:$PATH - cd bamboo-tests - npm test - cd - - make test - which eth - eth --version - mkdir -p /tmp/test - eth --test -d /tmp/test &> eth.log & - PID=$! - sleep 4 - endtoend.native - kill $PID - cat eth.log - opam pin add bamboo . -y - opam remove bamboo - opam install bamboo -y ================================================ FILE: LICENSE ================================================ Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "{}" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright 2016 Yoichi Hirai Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ================================================ FILE: Makefile ================================================ .PHONY: test bamboo clean dep bamboo: npm run build dep: npm install opam switch 4.02.3+buckle-master eval `opam config env` # It's important to install batteries first, so the proper version of rpc can be installed afterwards git clone https://github.com/bsansouci/batteries-included ./node_modules/batteries-included cd ./node_modules/batteries-included && opam pin add -y batteries . && cd ../.. opam install -y ocamlfind menhir rope zarith ppx_deriving rpc=1.9.52 cryptokit hex doc/spec.pdf: doc/spec.tex (cd doc; pdflatex -halt-on-error spec.tex; pdflatex -halt-on-error spec.tex) test: (cd src; sh ./run_tests.sh) clean: npm run clean ================================================ FILE: README.md ================================================ # Bamboo: a language for morphing smart contracts Cornell Blockchain says they can now maintain the Bamboo compiler. https://github.com/CornellBlockchain/bamboo
[![Join the chat at https://gitter.im/bbo-dev/Lobby](https://badges.gitter.im/bbo-dev/Lobby.svg)](https://gitter.im/bbo-dev/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Build Status](https://travis-ci.org/pirapira/bamboo.svg?branch=master)](https://travis-ci.org/pirapira/bamboo) Bamboo is a programming language for Ethereum contracts. Bamboo makes state transition explicit and avoids reentrance problems by default. See [manifest](doc/manifest.md) for the motivation, or [tutorial](doc/tutorial.md) if you want to deploy something first, or [semantics](doc/semantics.md) if you need something resembling a definition. ## Example Bamboo Code * [A payment channel](./src/parse/examples/00h_payment_channel.bbo) * [An ERC20 contract](./src/parse/examples/01b_erc20better.bbo) * [A vault](https://medium.com/@pirapira/implementing-a-vault-in-bamboo-9c08241b6755) ## Compiler The Bamboo compiler sometimes produces bytecode, which needs to be tested. As preparation, * install [opam](http://opam.ocaml.org/doc/Install.html) with OCaml 4.04.1 * `opam install bamboo` should install `bamboo`. When you check out this repository, ``` bamboo < src/parse/examples/006auction_first_case.bbo ``` produces a bytecode. Do not trust the output as the compiler still contains bugs probably. ``` bamboo --abi < src/parse/examples/006auction_first_case.bbo ``` prints ABI. ``` [{"type": "constructor", "inputs":[{"name": "_beneficiary", "type": "address"},{"name": "_bidding_time", "type": "uint256"},{"name": "_highest_bid", "type": "uint256"}], "name": "auction", "outputs":[], "payable": true},{"type":"fallback","inputs": [],"outputs": [],"payable": true}] ``` ## Developing Bamboo To try Bamboo in your local environment, run `make dep` from the project folder. That should install all dependencies. Once the installation process is done, run `eval $(opam config env)` and then you can build all targets using `make`, and run the tests with `make test`. When you modify the OCaml source of Bamboo, you can try your version by ``` $ make $ ./lib/bs/native/bamboo.native < src/parse/examples/006auction_first_case.bbo ``` **Embark** An [Embark plugin for Bamboo](https://github.com/embark-framework/embark-bamboo) is available. To use it, first install [Embark](https://embark.status.im/docs/) and add then add the plugin to your DApp. ```Javascript npm install -g embark embark new AppName cd AppName npm install embark-bamboo --save ``` then add embark-bamboo to the plugins section in ```embark.json```: ```Json "plugins": { "embark-bamboo": {} } ``` Afterwards Embark will recognize .bbo files and compile them with Bamboo. ## How to Contribute * notice problems and point them out. [create issues](https://github.com/pirapira/bamboo/issues/new). * test the bytecode like [this](doc/tutorial.md), but using other examples. You might find bugs in the compiler. * write new Bamboo code and test the compiler. * join the [Gitter channel](https://gitter.im/bbo-dev/Lobby). * spread a rumor to your friends who are into programming languages. ## Related Work ### Linden Scripting Language [Linden Scripting Language](http://wiki.secondlife.com/wiki/Getting_started_with_LSL#Introducing_States_and_Events) has similar organization of code according to `state`s. ### Obsidian [Obsidian](https://ieeexplore.ieee.org/document/7965268/) is another programming language that models smart contracts as state machines. Obsidian even tracks states of the contracts statically. ================================================ FILE: ReleaseNotes.txt ================================================ Version 0.0.03 (2018-05-04) * fixes incorrect characters in the ABI https://github.com/pirapira/bamboo/issues/279 * integration tests with Ganache-cli https://github.com/pirapira/bamboo/pull/263 * bamboo.js using BuckleScript https://github.com/pirapira/bamboo/pull/260 Version 0.0.02 (2017-10-13) * decimal literals #208 by @aupiff * detecting racing side-effects #186 * banning the keyword uint in favor of uint256 * More elegant parser using Menhir libraries ================================================ FILE: __tests__/compare-js-native.js ================================================ // A small script to test if both versions (JS and native) output the same // string given the same programs as input // To run: `node compare-js-native.js` const fs = require('fs'); const path = require('path'); const execSync = require('child_process').execSync; const examplesFolder = '../src/parse/examples'; fs.readdir(examplesFolder, (err, files) => { files.forEach(file => { console.log(`Comparing native vs js output for file: ${file}...`); const filePath = path.join(examplesFolder, file); const jsOutput = execSync(`node ../lib/js/src/exec-js/bambooJs.js < ${filePath}`).toString(); const nativeOutput = execSync(`../bamboo.native < ${filePath}`).toString(); const equal = jsOutput === nativeOutput; console.log(`Result: ${equal ? 'ok' : 'DIFF'}\n`); }); }) ================================================ FILE: _oasis ================================================ OASISFormat: 0.4 Name: bamboo Version: 0.0.03 Synopsis: A compiler targeting Ethereum Virtual Machine Authors: Yoichi Hirai License: Apache-2.0 Plugins: META (0.4) Homepage: https://github.com/pirapira/bamboo Description: Bamboo compiles a simple language to Ethereum Virtual Machine. The language is designed to keep programmers away from common mistakes. It features: state transition as recursion with potentially changing arguments, mandatory reentrance continuation when calling out, no loops, no assignments except to mappings and partial compliance with common Ethereum ABI. SourceRepository opam-pin Type: Git Location: https://github.com/pirapira/bamboo.git Branch: master Executable bamboo Path: src/exec Install: true BuildTools: ocamlbuild MainIs: bamboo.ml CompiledObject: best BuildDepends: parse, codegen Library ast Path: src/ast Install: false BuildTools: ocamlbuild Modules: Contract, Syntax, TypeEnv, Type, PseudoImm, Evm, Location, Ethereum BuildDepends: basics, cryptokit (>= 1.12), hex Library basics Path: src/basics Install: false BuildTools: ocamlbuild Modules: Assoc, Hexa, Label, Misc, Storage BuildDepends: cross-platform Library cross-platform Path: src/cross-platform-for-ocamlbuild Install: false BuildTools: ocamlbuild Modules: WrapBn, WrapCryptokit, WrapList, WrapString, WrapOption BuildDepends: batteries,rope,cryptokit (>= 1.12),hex Library codegen Path: src/codegen Install: false BuildTools: ocamlbuild Modules: CodegenEnv, Codegen, EntrypointDatabase, LayoutInfo, LocationEnv, Parse BuildDepends: basics, ast, parse Library parse Path: src/parse Install: false BuildTools: ocamlbuild Modules: Lexer BuildDepends: ast, menhirLib ================================================ FILE: _tags ================================================ # OASIS_START # DO NOT EDIT (digest: c348eeadfb15aa1af2d805f976b82290) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library cross-platform "src/cross-platform-for-ocamlbuild/cross-platform.cmxs": use_cross-platform : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_rope # Library basics "src/basics/basics.cmxs": use_basics : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_rope : use_cross-platform # Library ast "src/ast/ast.cmxs": use_ast : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_rope : use_basics : use_cross-platform # Library parse "src/parse/parse.cmxs": use_parse : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_menhirLib : pkg_rope : use_ast : use_basics : use_cross-platform # Library codegen "src/codegen/codegen.cmxs": use_codegen : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_menhirLib : pkg_rope : use_ast : use_basics : use_cross-platform : use_parse # Executable bamboo : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_menhirLib : pkg_rope : use_ast : use_basics : use_codegen : use_cross-platform : use_parse : pkg_batteries : pkg_cryptokit : pkg_hex : pkg_menhirLib : pkg_rope : use_ast : use_basics : use_codegen : use_cross-platform : use_parse # OASIS_STOP true: use_menhir : -traverse : -traverse : -traverse : -traverse ================================================ FILE: bsconfig.json ================================================ { "name": "bamboo", "version": "0.0.02", "bsc-flags": "-w -27 -g", "warnings": { "number": "-40+6+7-26-27+32..39-28-44+45", "error": "+8" }, "bs-dependencies": [ "bs-bn.js" ], "ocamlfind-dependencies": [ "batteries", "cryptokit", "hex", "ppx_deriving", "ppx_deriving_rpc", "rpclib.json" ], "generators": [ { "name": "ocamllex", "command": "ocamllex $in" }, { "name": "menhir", "command": "menhir $in" } ], "sources": { "dir": "src", "subdirs": [ {"dir": "ast"}, {"dir": "basics"}, {"dir": "codegen"}, {"dir": "cross-platform"}, {"backend": "native", "dir": "exec"}, {"backend": "js", "dir": "exec-js"}, {"dir": "lib"}, {"dir": "parse", "generators": [ { "name": "ocamllex", "edge": ["lexer.ml", ":", "lexer.mll"] }, { "name": "menhir", "edge": ["parser.ml", "parser.mli", ":", "parser.mly"] } ] } ] }, "entries": [ { "backend": "native", "main-module": "Bamboo" }, { "backend": "native", "main-module": "Codegen_test" }, { "backend": "native", "main-module": "Codegen_test2" }, { "backend": "native", "main-module": "Lib_test" }, { "backend": "native", "main-module": "Hex_test" }, { "backend": "native", "main-module": "Parser_test" }, { "backend": "native", "main-module": "Ast_test" }, { "backend": "native", "main-module": "EndToEnd" }, { "backend": "js", "main-module": "BambooJs" } ], "refmt": 3 } ================================================ FILE: doc/manifest.md ================================================ # Bamboo Manifest ## Problem Smart contracts should reduce surprises. The code should reveal what can happen in which order, and the same ordering must be enforced mechanically. This is not done in the usual way of writing smart contracts where a smart contract is described as several interface functions. In the following example, the names of functions suggest the timing of the calls, but this ordering can only be enforced by careful timestamp checking or global state tracking in the body of the functions. ``` contract CrowdFund() { case(void toBeCalledDuringFunding()) { // ... } case(void toBeCalledAfterFailure()) { // ... } case(void toBeCalledAfterSuccess()) { // ... } case(void notSureWhatThisDoes()) { // ... } } ``` To make my point clearer, I added the last function `notSureWhatThisDoes()`. Whenever such a function exists the temporal order is ambiguous. An interface function can be called at any moment by default. A closer look is necessary for every interface function before a reader or the machine can enumerate the possible orderings of events. ## Solution The solution is polymorphic contracts. According to the stages, a contract changes its signature. ``` contract Funding() { case(bool toBeCalledDuringFunding()) { // something something return true then become Funding(); } case(bool endFunding()) { if (something) return (true) then become FundingSuccess(); else return (false) then become FundingFailure(); } } contract FundingSuccess() { case(void toBeCalledAfterSuccess()) { // something } } contract FundingFailure() { case(void toBeCalledAfterFailure()) { // something } } ``` All of these contracts `Funding`, `FundingSuccess` and `FundingFailure` occupies the same address. The initial contract `Funding` becomes `FundingSuccess` or `FundingFailure`. Where has gone the `notSureWhatThisDoes()` function in the previous example? It's not there because, well, I am not sure where it goes. The new style forces temporal organization of the code lines. ### Syntax After some polishing I ended up to something like [this](../src/parse/examples/00d_auction.bbo). There is some influence from Erlang. ### Not to have This language is designed to facilliate a particular style. So the language will not support features like: * loop constructs (`for`, `while`, ...). Due to the constant block gas limit, loops should be avoided and each iteration should be done in separate transactions. * assignments into storage variables, except array elements. Instead of assigning a new value to a storage variable, the new value can be given as an argument in the continaution (e.g. `return () then auction(new_highest_bidder, ...)` ================================================ FILE: doc/semantics.md ================================================ # Bamboo Semantics Sketch This document describes the semantics of the Bamboo language. This is an informal sketch written as a preparation for the coming Coq or K code. ## Overview ### Arena of the Game A program written in Bamboo, once deployed, participates in a game between the program and the world. In this game, the world makes the first move, the program makes the second move, and so on alternatively. Neither the world or the program makes two moves in a row. This document aims at defining the choice of the program's move, given a sequence of earlier moves. The world can make the following three kinds of moves: * calling the program * returning into the program * failing into the program The program can make the following five kinds of moves: * calling an account * deploying code * returning * failing * destroying itself A sequence of moves can be equipped with a number called the nesting. The empty sequence is associated with zero-nesting. Initially, when the program is deployed, the program is not running (or running with zero-nesting). When the program is not running, the world can only call the program. When the world calls the program, the nesting increases by one. When the program returns, fails, or destroys itself, the nesting decreases by one. From the above sentences, you should be able to prove that the nesting never goes below zero. ### Bamboo's Strategy In general, a program needs to decide on a move after any sequence of moves that ends with the world's move. However, Bamboo does not remember the whole sequence of moves, but just remembers the "program's state". The Bamboo semantics computes the program's next move only using the stored program's state and the previous move made by the world. In addition to the program's move, the Bamboo semantics specifies the program's new altered state for later use. ### Bamboo's Program State The program's state has three components: a persistent state, a `killed` flag, and pending execution states. When the game is `n`-running, the program's state contains `n` pending execution states. A persistent state is either the special aborting element or a name of the contract followed by its arguments. In the simple case, when the source code says ``` contract A () ``` the persistent state can be simply `A()`. In a more complicated example, when the source code says ``` contract B (uint totalSupply) ``` the program's state can be `B(0)`, `B(3000)` or `B()`. However, `B()` is not a program state. `B(1,2)` is not a persistent state either because the number of arguments do not match the number of parameters in the source code. ### An example of Persistent States Let's consider one Bamboo source code, which contains three contracts: ``` contract A() { default { return then become B(); } } contract B() { default { return then become C(); } } contract C() { default { selfdestruct(this); } } ``` When this source code is compiled and deployed, we get a program whose state consists of a persistent state and no pending execution states. The initial persistent state is `A()`. The initial `killed` flag is `false`. When the world calls the program, the program might return, leaving the persistent state `B()`; intuitively, that's the meaning of `return then become B()`. Otherwise, there is a possibility that the program fails, leaving the persistent state as `A()` (this possibility comes from EVM's out-of-gas). When the world calls the program again, the program might return, leaving the persistent state `C()`; intuitively, that's the meaning of `return then become C()`. Otherwise, there is a possibility that the program fails, leaving the persistent state as `B()` (this possibility comes from EVM's out-of-gas). When the world calls the program again, the program might destroy itself. This is described in `selfdestruct(this)`. The form `selfdestruct(.)` takes one argument, which specifies the account where the remaining ETH balance goes. The keyword `this` represents the Ethereum account where the program is deployed. Bamboo inherits EVM's special behavior when the program's own address is specified as the receiver of the remaining balance. In that case, the remaining balance disappears. After selfdestruction, the program's state contains the `killed` flag `true`. Again, there is a possibility that the program fails, leaving the persistent state as `C()` and the `killed` flag `false` (this possibility comes from EVM's out-of-gas). ### What happens after selfdestruction After the program destroys itself, if the world calls the program, the program simply returns the empty data given enough gas. The program might fail if there is not enough gas. (TODO: make sure the compiler realizes this behavior. Issue [#170](https://github.com/pirapira/bamboo/issues/170).) ### What happens if the selfdestruction is reverted? People familiar with EVM semantics might ask what happens when state changes are reverted. The Bamboo semantics do not see the state reversion. From a history in the EVM, you can pick up unreverted executions, and the Bamboo semantics can run there. (TODO: maybe I should not mention the possibilities that the program fails because of out-of-gas in EVM?) ## Pending Execution State As mentioned, a program's state contains a list of pending execution states. Moreover, after the world makes a move and before the program makes a move, the abstract machine keeps track of the current pending execution state. A pending execution state contains an evaluation point, a variable environment and an annotating function. Each component is described below. ### An evaluation point Any pending execution state contains an evaluation point. An evaluation point is either a sentence or an expression in the source code. When identical expressions (resp. sentences) appear in the source code, they are considered different expressions (resp. sentences) if their locations are different. A Bamboo source code is a list of contracts. A contract contains a list of cases. A case contains a list of sentences. A sentence contains sentences and/or expressions. An expression contains sentences and/or expressions. The current evaluation point is either a sentence or an expression in the source code. (TODO: there should be a separate document called Bamboo Syntax.) ### A variable environment Any pending execution state contains a variable environment. A variable environment is a finite map from identifiers to values. (TODO: describe identifiers in a separate document Bamboo Syntax). A value is a sequence of 32 bytes. When values are interpreted as numbers, they are encoded in big-endian. The empty variable environment maps no identifiers to values. ### An annotating function Any pending execution state contains an annotation function. An annotation function is a finite map from expressions in the source code to values or persistent states. In other words, given an expression in the source code, an annotation function gives nothing, a value, or a persistent state. When identically looking expressions appear in the source code, they are considered different if their locations are different. The empty annotating function maps no expressions to values. ## When the World calls the Program When the world calls the program, the world can specify one of the two kinds of calls: calling the default case or calling a named case. Anyway, when the world calls the program, the program first looks up the source code for the contract specified in the permanent state. For example, when the permanent state is `A()`, the program tries to find a contract called `A` with zero arguments in the source code. If such a contract is not found in the source code, the Bamboo compiler is broken. If multiple such contracts are found in the compiler, the Bamboo compiler is also broken. Moreover, if the persistent state of the program contains `killed` flag being true, the program returns or fails at random (the EVM knows if there is enough gas to execute `STOP`, but the Bamboo semantics is not aware of the EVM's choice). ### The world can call the default case If such a contract is found in the source code, and if the world has called the default case, the program then looks for the `default` case in the contract. If there is none, the program fails. If there are more than one `default` case, the Bamboo compiler is broken. If there is one such `default` case, the `default` case contains a list of sentences. If the list of sentences is empty, the Bamboo compiler is broken. Otherwise, the evaluation point is set to the first sentence in the list of sentences. The combination of the evaluation point, the empty variable environment, and the empty annotating function is kept as the current pending execution state. ### The world can call a named case When the world calls a named case, the world needs to specify an identifier (name of the case), a list of ABI types and a list of values. Bamboo recognizes the following ABI types: * uint256 * uint8 * bytes32 * address * bool These types are just meaningless symbols. A value is a sequence of 32 bytes. When the world calls a named case, the program looks up the source code for the contract specified in the permanent state. If the contract is not found, the Bamboo compiler is broken. If multiple contracts are found matching the permanent state, the Bamboo compiler is also broken. The program searches the contract in the source code for a case that matches the world's call. For instance, when the world specified a named case `f(uint256, bool, address)`, the case `case (f (uint256 x, bool y, address z))` is a matching case. When there are no cases that match the world's call, the program proceeds as if the world specified the default case. If there are multiple cases that match the world's call, the Bamboo compiler is broken. The case contains a list of sentences. If the list is empty, the Bamboo compiler is broken. Otherwise, the evaluation point is set to the first sentence in the list of sentences. To clarify the first-last direction, the first sentence is the closest to the case's header. If the world's call contains more values than ABI types, the program fails. If the world's call contains fewer values than ABI types, the program also fails. Otherwise, a variable environment is formed in a straightforward way (TODO: explain). The combination of the evaluation point, the variable environment, and the empty annotating function is kept as the current pending execution state. ## When there is a current pending execution state When there is a current pending execution state, there is always a possibility that the program fails immediately. This is because of the underlying EVM mechanism can run out of gas, but Bamboo is not aware of this mechanism. From this document's view, the program just fails at any moment randomly. Moreover, when the evaluation point in the current pending execution state is an `abort;` sentence, the program certainly fails. Otherwise, when the evaluation point in the current pending execution state is a `return then become X;` sentence, if the annotating function does not map `X` to anything, the evaluation point is set to `X`. When the annotation function maps `X` to a persistent state, the program returns and leaves the persistent state specified by the annotation function. Otherwise, when the evaluation point in the current pending execution state is a `return e then become X;` sentence, if the annotating function does not map `X` to anything, the evaluation point is set to `X`. When the annotation function maps `X` to a persistent state, but the annotation function does not map `e` to anything, the evaluation point is set to `e`. When the annotation function maps `X` to a persistent state and the annotation function maps `e` to a value, the program returns the value associated with `e` and leaves the persistent state associated with `X`. When the annotation function does anything else, the Bamboo compiler is broken. Otherwise, when the evaluation point in the current pending execution state is a `void = X;` sentence, if the annotating function does not map `X` to anything, the evaluation point is set to `X`. Otherwise, the evaluation point advances from the sentence (see below for how an evaluation point advances from a sentence in the source code). Otherwise, when the evaluation point in the current pending execution state is a `TYPE V = X` where `TYPE` is a name of a type, `V` is an identifier and `X` is an expression, if the annotating function does not map `X` to anything, the evaluation point is set to `X`. Otherwise, if the annotating function maps `X` to a value, the variable environment is updated to map `V` to the value, and the evaluation point advances from this sentence (see below for what it is that the evaluation point advances). Otherwise, when the evaluation point in the current pending execution state is an `if (C) then B0 else B1` sentence, where `C` is an expression, `B0` is a block and `B1` is another block, the evaluation point is set to `C` if the annotating function does not map `C` to anything. Otherwise, when the annotation function maps `C` to zero, the evaluation point advances into `B1` (see below for what it is that the evaluation point advances into a block). Even otherwise, when the annotation function maps `C` to a non-zero value, the evaluation point advances into `B0`. When the annotation function maps `C` to something else, the Bamboo compiler is broken. Otherwise, when the evaluation point in the current pending execution state is a `log E(e0, e1, ..., en)` sentence, if the annotation function maps any `ek` to nothing, the last such argument becomes the evaluation point. Otherwise, the evaluation point moves advances from this sentence (see below for what it is for an evaluation point to advance). Otherwise, when the evaluation point in the current pending execution state is a `selfdestruct(X);` sentence, if the annotating function does not map `X` to anything, the evaluation point is set to `X`. When the annotating function maps `X` to a value, the program destroys itself, specifying the value as the inheritor. The current pending execution state is discarded. The `killed` flag is set in the persistent state. (When the program has been called from a Bamboo program, the world then returns into that Bamboo program, not failing into it.) Otherwise, when the evaluation point in the current pending execution state is an identifier occurrence, the program looks up the variable environment. If the variable environment does not map the identifier occurrence to a value, the Bamboo compiler is broken. Otherwise, when the variable environment maps the identifier occurrence to a value, the annotating function now associates the identifier occurrence with the value. The evaluation point is set to the surrounding expression or sentence. Otherwise, when the evaluation point in the current pending execution state is a call `C.m(E1, E2, ...,E_n) reentrance { abort; }`, if the annotating function does not map `C` to anything, the evaluation point is set to `C`. Otherwise, if the annotation function maps any of `E_k` to nothing, the evaluation point is set to the last such argument. Otherwise, the program calls an account of address, specified by the annotation of `C`. The call is on a named case `m` (TODO: for completing this clause, we need some information about the types of arguments of `m`. We need some information in the persistent state), together with annotations of `E1`, ... `E_n`. The program's state should now contain the current pending execution state as the last element in the list of pending execution states. Moreover, the persistent state in the program's state is now the aborting element. Otherwise, when the evaluation point in the current pending execution state is a deployment `deploy C(E1, E2, E_n) reentrance { abort; }`, if the annotation function maps any of `E_k` to nothing, the evaluation point is set to the last such argument. Otherwise, the program deploys the contract `C` with a packing of annotations of `E_k`s. If the contract `C` does not appear in the source code, the Bamboo compiler is broken. The program's state should now contain the current pending execution state as the last element in the list of pending execution states. Moreover, the persistent state in the program's state is now the aborting element. ## How to advance an evaluation point When an evaluation point advances from a sentence, if the sentence belongs to a case's body, and there is a next sentence, the next sentence becomes the evaluation point. Otherwise, if the sentence belongs to a case's body but there is no next sentence, the Bamboo compiler has an error. Otherwise, when the sentence belongs to a block, and there is a next sentence, the next sentence becomes the evaluation point. Otherwise, when the sentence belongs to a block and there is no next sentence, the evaluation point advances from the sentence containing the block. Otherwise, when the sentence belongs to a sentence, the evaluation point advances from the containing sentence. ## When the World returns into the Program When the world returns into the program but the program's state does not contain any pending execution state, something is very wrong. Otherwise, the program finds in its state the last element in the list of pending execution states. This element is removed from the program's state and becomes the current pending execution state. The execution continues according to the execution point in the current pending execution state. ## When the World fails into the Program The program fails as well. ## Adding Mappings Sometimes, a contract contains a mapping. For example, when a contract in the source code looks like ``` A(address => uint256 balances) { ... } ``` The permanent state associates a value for `balances`. Moreover, the permanent state contains a grand mapping that takes two values and return a value. This grand mapping `M` is common to all mappings in the permanent state. When `balances[3]` is looked up, actually, `M(<>, 3)` is looked up (where `<>` is the value that he permanent state associates to `balances`). When a program is deployed, the grand mapping in the permanent state maps everything to zero. Moreover, the permanent state contains a value called the array seed. When the program is deployed, the initial permanent state associates `balances` to one, and the array seed is two. In general, when a contract contains `n` mappings, the initial permanent state associates these mappings to `1`, `2`, ..., `n`. Moreover, the initial permanent state has the array seed `n + 1`. When the evaluation point is an assignment to a mapping `m[idx0][idx1]...[idx_k] = V`, the program looks up the annotating function for `m[idx0][idx1]...[idx_k - 1]`. If the annotating function does not map this part to anything, `m[idx0][idx1]...[idx_k - 1]` becomes the evaluation point. Otherwise, if the annotating function does not map `idx_k` to anything, `idx_k` becomes the evaluation point. Otherwise, if the annotating function does not map `V` to anything, `V` becomes the evaluation point. Otherwise, when all of these are mapped to some value, the grand mapping is updated to map the evaluation of `m[idx0]...[idx_k - 1]` and `idx_k` into the evaluation of `V`, and the evaluation point advances from the assignment sentence. When the evaluation point is a mapping lookup `m[idx]`, the program looks up the annotating function for `m`. If the annotating function does not map `m` to anything, `m` becomes the evaluation point. Otherwise, if the annotating function maps `m` to zero, the program assigns a seed to `m` (see below for what it is for a program to assign a seed to `m`). Otherwise, if the annotating function does not map `idx` to anything, the evaluation point becomes `idx`. Otherwise, the annotating function is updated to map `m[idx]` to `M(<>, <>)` where `<>` and `<>` are the values that the annotation function returns for `m` and `idx`, and the evaluation point is set to the surrounding expression or sentence. When the program assigns a new array seed to `m[idx]`, the grand mapping function is updated so that `M(<>, <>)` is the array seed, where `<>` and `<>` represents the values that the annotation function maps `m` and `idx` into. Then, the array seed is incremented. When the annotation function does not map `m` or `idx` to any value, the Bamboo compiler is broken. ================================================ FILE: doc/spec.tex ================================================ \documentclass{book} \usepackage{stmaryrd} \usepackage{amsmath} \newcommand{\todo}[1]{\underline{TODO: {#1}}} \newcommand{\sem}[1]{\llbracket{#1}\rrbracket} \newcommand{\evalE}[1]{E_\mathrm{e}\left({#1}\right)} \newcommand{\evalS}[1]{E_\mathrm{s}\left({#1}\right)} \newcommand{\expressionsentence}[1]{\mathsf{void}={#1}\mathsf{;}} \title{Bamboo Specification---An Early Draft} \begin{document} \maketitle This specification contains some exercises. Please try to solve them at least mentally. Your solutions are welcome at \texttt{https://gitter.im/bbo-dev/Lobby}. \todo{use url} \chapter{Preliminaries} \section{What Qualifies a Bamboo Implementation} \ldots A Bamboo compiler can refuse to compile certain valid programs. \section{Notations} $v \in A$ says $v$ is an element of a set~$A$. \chapter{Syntax} \section{Keywords} \newcommand{\abort}{\text{\texttt{abort;}}} \newcommand{\true}{\text{\texttt{true}}} \newcommand{\false}{\text{\texttt{false}}} \newcommand{\msgsender}{\text{\texttt{msg.sender}}} \newcommand{\msgvalue}{\text{\texttt{msg.value}}} \newcommand{\this}{\text{\texttt{this}}} \newcommand{\now}{\text{\texttt{now}}} \newcommand{\paren}[1]{\mathtt{(}{#1}\mathtt{)}} \newcommand{\logicalAnd}[2]{{#1}\mathbin{\text{\texttt{\&\&}}{#2}}} \newcommand{\logicalNot}[1]{\mathop{\text{\texttt{not}}}{#1}} \newcommand{\balance}[1]{\text{\texttt{balance}}\mathtt{(}{#1}\mathtt{)}} \newcommand{\arrayAccess}[2]{{#1}[{#2}]} \newcommand{\lt}[2]{{#1} \mathop{\text{\texttt{<}}} {#2}} \newcommand{\gt}[2]{{#1} \mathop{\text{\texttt{>}}} {#2}} \newcommand{\eq}[2]{{#1} \mathop{\text{\texttt{==}}} {#2}} \newcommand{\notEq}[2]{{#1} \mathop{\text{\texttt{!=}}} {#2}} The following sequences of characters are \textit{keywords}. \begin{itemize} \item $\true$ \item $\false$ \item $\this$ \item $\now$ \item \texttt{not} \item \texttt{contract} \item \texttt{default} \item \texttt{case} \item \texttt{abort} \item \texttt{uint8} \item \texttt{uint256} \item \texttt{bytes32} \item \texttt{address} \item \texttt{bool} \item \texttt{if} \item \texttt{else} \item \texttt{then} \item \texttt{become} \item \texttt{return} \item \texttt{deploy} \item \texttt{with} \item \texttt{reentrance} \item \texttt{selfdestruct} \item \texttt{block} \item \texttt{void} \item \texttt{event} \item \texttt{log} \item \texttt{indexed} \end{itemize} \todo{Use a maththm like environment for exercises.} Exercise: which of the following are keywords? \begin{enumerate} \item \texttt{True} \item \texttt{true} \end{enumerate} \section{Identifier} An \textit{identifier} is a sequence of characters that matches the following regular expression (but is not a keyword): \begin{verbatim} ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* \end{verbatim} \todo{define identifier} Exercise: which of the following are identifiers? \\ \todo{complete} \section{Syntactic Types} The following sequences of characters are \textit{syntactic types}. \begin{itemize} \item \texttt{void} \item \texttt{uint256} \item \texttt{bool} \item \texttt{uint8} \item \texttt{bytes32} \item \texttt{address} \item \texttt{mapping } $T$ \texttt{=>} $T'$ when $T$ and $T'$ are syntactic types \item any identifier except those listed above. \end{itemize} Every syntactic type except \texttt{void} is a \textit{non-\texttt{void} syntactic type}. Exercise: which of the following is true? \begin{enumerate} \item \texttt{uint256} is the set of integers at least zero and at most $2^{256} - 1$. \item \texttt{uint256} is the set of 256-bit words. \item none of the above. \end{enumerate} \section{Expressions} A \textit{message-info} is a value-info followed by a reentrance-info. A \textit{case-call-expression} looks like \[ e . c (e_1, \ldots, e_n)\ m \] with $e$ and $e_i$ ($1 \le i \le n$) being expressions and $m$ a message-info. A \textit{call-expression} is either a case-call-expression or a default-call-expression. A \textit{deploy-expression} looks \[ \text{\texttt{deploy}}\ i(e_1,\ldots,e_n)\ m \] with $i$ being an identifier, $e_i$ ($1 \le i \le n$) an expression and $m$ a message-info. \textit{Expressions} are inductively defined as follows. \begin{itemize} \item $\true$ is an expression. \item $\false$ is an expression. \item $\msgsender$ is an expression. \item $\msgvalue$ is an expression. \item $\this$ is an expression. \item $\now$ is an expression. \item An identifier is an expression. \item When $e$ is an expression, $\paren{e}$ is an expression. \item When $e$ is an expression, $\logicalNot{e}$ is an expression. \item When $e$ is an expression, $\balance{e}$ is an expression. \item A deploy-expression is an expression. \item A call-expression is an expression. \item AddressExp? What is an AddressExp? \item When $e_0$ and $e_1$ are expressions, the following are expressions \begin{itemize} \item $\logicalAnd{e_0}{e_1}$ \item $\lt{e_0}{e_1}$ \item $\gt{e_0}{e_1}$ \item $\notEq{e_0}{e_1}$ \item $\eq{e_0}{e_1}$ \item $\arrayAccess{e_0}{e_1}$ \item $e_0 + e_1$ \item $e_0 - e_1$ \item $e_0 \times e_1$ \end{itemize} \end{itemize} Exercise: prove that \texttt{99a} is not an expression. \section{Sentences} A \textit{return sentence} looks \[ \texttt{return}\, e_0 \,\texttt{then}\, \texttt{become}\, i(e_1,\ldots,e_n); \] with $i$ being an identifier and $e_i$ ($0 \le i \le n$) an expression. An \textit{assignment sentence} looks \[ l = e; \] with $l$ being a left-expression and $e$ an expression. A \textit{variable initialization sentence} looks \[ t i = e; \] with $t$ being a type, $i$ and identifier and $e$ an expression. An \textit{expression sentence} looks \[ \texttt{void}\, = \,e; \] with $e$ being an expression. An \textit{if sentence} looks \[ \texttt{if}\, (e)\, B \] with $e$ being an expression and $B$ either a block or a sentence (this forms a mutual induction together with the definition of sentences). An \textit{if-then-else sentence} is looks \[ \texttt{if}\, (e)\, B_0 \,\texttt{else}\, B_1 \] with $e$ being an expression and each $B_i$ either a block or a sentence (this forms a mutual induction together with the definition of sentences). A \textit{logging sentence} looks \[ \texttt{log}\,i(e_1, \ldots, e_n) \] where $n \ge 0$. Each $e_j$ is an expression. $i$ is an identifier. A \textit{selfdestruct sentence} looks \[ \texttt{selfdestruct}\, e; \] with $e$ being an expression. \textit{Sentences} are inductively defined as follows. \begin{itemize} \item $\abort$ is a sentence. \item a return sentence is a sentence. \item an assignment sentnece is a sentence. \item a variable initialization sentence is a sentence. \item an expression sentence is a sentence. \item an if sentence is a sentence. \item an if-then-else sentence is a sentence. \item a logging sentence is a sentence. \item a self-destruct sentence is a sentence. \end{itemize} \section{Blocks} A \textit{block} is a possibly empty sequence of stentences surrounded by \texttt{\{} and \texttt{\}}. \todo{talk about whitespaces, perhaps.} \section{Cases} A \textit{case header} is either a default case header or a named case header. A \textit{case} is a case header followed by a block. \section{Contract Headers} A \textit{contract header} looks \[ \mathtt{contract} i(t_1 i_1, \ldots, t_n i_n); \] where $i$ and $i_j$ ($1 \le j \le n$) are identifiers, $t_j$ ($1 \le j \le n$) are syntactic types. \section{Contracts} A \textit{contract} is a contract header followed by a \texttt{\{}, some (possibly no) cases and a \texttt{\}}. \subsection{Contract's Signature} $(\mathtt{auction}, [\mathtt{address}, \mathtt{uint256}, \mathtt{address}, \mathtt{uint256}])$. Exercise: what is the signature of the following contract? \todo{complete the question} \subsection{Contract Body} A \textit{contract body} is a possibly empty sequence of cases surrounded by \texttt{\{} and \texttt{\}}. \subsection{Contract Definitions} A \textit{contract definition} is a contract header followed by a contract body. \section{Event Declarations} An \textit{event declaration} looks like \[ i(e_1, \ldots, e_n); \] where $n \ge 0$, each $e_j$ is an event argument, and $i$ is an identifier. \section{Program} A \textit{program} is a possibly empty sequence of contract definitions and event declarations. \chapter{Semantics} \section{Notations} \todo{describe $\in$} \todo{describe pi} \section{States} \subsection{Values} A \textit{value} is a 256-bit word. We pick something called $\bot$ (pronounced ``bottom'') which is not a value. The choice should not affect the meaning of a Bamboo program. (We might specify a set of values for each syntactic type in the future.) \subsection{A Contract's States} A contract has \textit{states}. When a contract has a signature $(x, [T_1, T_2, \ldots, T_n])$ ($n \ge 0$), the set of the states of the contract~$C$ is $[[C]] \equiv \Pi_{i = 0}^{n} \sem{T_i}$. \subsection{A Program's Account States} A program determines a set of \textit{account states}. A program contains contract definitions $C_1, \ldots, C_n$ ($n \ge 0$), disjoint union of $[[C_i]]$ ($1 \le i \le n$). \section{Dynamics} \subsection{Variable Environment} A \textit{variable environment} is a partial map that takes identifiers and may or may not return a value. When a variable environment $\sigma$ maps and identifier~$i$ to a value~$v$, we write \[ \sigma(i) = v \] \subsection{Current Call} A \textit{current call} $c = (c_\mathrm{s}, c_\mathrm{v}, c_\mathrm{t})$ is a tuple of \begin{itemize} \item a value $c_\mathrm{s}$ called the \textit{sender}, \item a value $c_\mathrm{v}$ called the \textit{transferred amount} and \item a value $c_\mathrm{t}$ called the \textit{timestamp}. \end{itemize} \subsection{World Oracle} \subsubsection{Call Queries} \subsubsection{Create Queries} \subsubsection{Balance Queries} \subsection{Timestamp query} \newcommand{\timestampQuery}{\text{\texttt{timestamp?}}} The time stamp query~$\timestampQuery$ is something different from any query that appears above. Apart from that, $\timestampQuery$ can be anything, and the behavior of Bamboo programs should not be affected by the concrete choice of $\timestampQuery$ (with some adaptations on world oracles). \subsection{Current Account Query} \newcommand{\thisQuery}[0]{\text{\texttt{this?}}} The current account query~$\thisQuery$ is something different from any query that appears above. \subsection{Sender Query} \newcommand{\senderQuery}{\text{\texttt{sender?}}} The sender query~$\senderQuery$ is something different from any query that appears above. \subsection{Value Query} \newcommand{\valueQuery}{\text{\texttt{value?}}} The value query~$\valueQuery$ is something different from any query that appears above. \subsubsection{World Oracle} Call queries, create queries, \todo{fill in} are \textit{oracle queries}. A \textit{world oracle} is defined coinductively as a function that takes an oracle query and returns a pair of a value and a world oracle. When a world oracle~$w$ takes a query~$q$ and returns a pair of a value~$v$ and a world oracle~$w'$, we write $w(q) = (v, w')$. \todo{Add a possibility that the world oracle calls into the program again.} \subsection{Evaluation of an Expression} The evaluation for expressions takes \begin{itemize} \item an expression, \item a current call, \item a world oracle and \item a variable environment. \end{itemize} It returns \begin{itemize} \item a value or $\bot$ and \item a world oracle \end{itemize} \todo{say it's inductively defined over the definition of expressions}. \subsubsection{Evaluation of Literals} \textit{Literals} are those keywords whose evaluation is defined below. \begin{itemize} \item $\evalE{\boxed{\true}, c, w, \sigma} := (1, w)$ \item $\evalE{\boxed{\false}, c, w, \sigma} := (0, w)$ \item $\evalE{\boxed{\now}, c, w, \sigma} := w(\timestampQuery)$ \item $\evalE{\boxed{\this}, c, w, \sigma} := w(\thisQuery)$ \item $\evalE{\boxed{\msgsender}, c, w, \sigma} := w(\senderQuery)$ \item $\evalE{\boxed{\msgvalue}, c, w, \sigma} := w(\valueQuery)$ \end{itemize} balance(x) sends a balance query on the world oracle. \subsubsection{Evaluation of an Identifier} An identifier~$i$ is evaluated as follows: \[ \evalE{\boxed{i}, c, w, \sigma} := (\sigma(i), w) \] Note that $\sigma(i)$ can be $\bot$. \subsubsection{Evaluation of a new-expression} \todo{Consider new-expressions with nontrivial continuation later. That requires an interaction between the program and the world oracle. } \subsubsection{Evaluation of a call-expression} \todo{Consider call-expressions with nontrivial continuation later. That requires an interaction between the program and the world oracle. } \subsubsection{Evaluation of Binary Operators} \[ \evalE{\boxed{\logicalAnd{e_0}{e_1}}, c, w, \sigma} := \begin{cases} (v_0, w_0) & \text{if}\ v_0 = 0\ \text{or}\ v_0 = \bot \\ (v_1, w_1) & \text{otherwise} \end{cases} \] where \[ \evalE{\boxed{e_0}, c, w, \sigma} = (v_0, w_0) \] and \[ \evalE{\boxed{e_1}, c, w_0, \sigma} = (v_1, w_1) \] \[ \evalE{\boxed{\lt{e_0}{e_1}}, c, w, \sigma} := \begin{cases} (1, w_0) &\text{if}\ v_0 \neq \bot, v_1 \neq\bot\ \text{and}\ v_0 < v_1 \\ (0, w_0) &\text{if}\ v_0 \neq \bot, v_1 \neq\bot\ \text{and}\ v_0 \ge v_1 \\ (\bot, w) &\text{if}\ v_0 = \bot \ \text{or}\ v_1 = \bot \end{cases} \] where \[ \evalE{\boxed{e_1}, c, w, \sigma} = (v_1, w_1) \] and \[ \evalE{\boxed{e_0}, c, w, \sigma} = (v_0, w_0) \] \[ \evalE{\boxed{\arrayAccess{e_0}{e_1}}, c, w, \sigma, M} := (w_0, M(v_0, v_1)) \] where \[ \evalE{\boxed{e_1}, c, w, \sigma, M} = (v_1, w_1) \] and \[ \evalE{\boxed{e_0}, c, w_1, \sigma, M} = (v_0, w_0) \] \subsection{Evaluation of a Sentence} The evaluation function for sentences take \begin{itemize} \item a sentence, \item a current call, \item a variable environment and \item a world oracle \end{itemize} and returns \begin{itemize} \item a variable environment, \item a world oracle \item and optionally an account state. \end{itemize} \todo{Show two forms of equations: one without an account state, the other with an account state.} \subsubsection{Evaluation of an Expression Sentence} \[ \evalS{\boxed{\expressionsentence{e}}, c, \sigma, w} := (\sigma', w') \] where \[ \evalE{\boxed{e}, c, \sigma, w} = (v, \sigma', w') \] \subsection{Evaluation of a Case} The evaluation function of a case takes \begin{itemize} \item A contract state \item a world oracle \item a case call \end{itemize} and returns \begin{itemize} \item an account state \item a world oracle \end{itemize} \subsection{Evaluation of a Contract} The evaluation function of a contract takes \begin{itemize} \item A contract state \item a world oracle \item a contract call \end{itemize} and returns \begin{itemize} \item An account state \item a world oracle \end{itemize} \subsection{Evaluation of a Program} The evaluation function of a program takes \begin{itemize} \item an account state \item a world oracle \item a program call \end{itemize} and returns \begin{itemize} \item an account state \item a world oracle \end{itemize} \section{Account Initialization} \subsection{Account Deployment Query} \subsection{Initial Variable Environment} \chapter{Connection to EVM} \section{Bamboo Account State as an EVM Account State} \section{Queries as EVM instructions} \end{document} ================================================ FILE: doc/testing-bytecode.md ================================================ Testing the Bytecode from bbo ============================= Getting a Bytecode ------------------ After following the [readme](../README.md), ``` ./lib/bs/native/bamboo.native < src/parse/examples/006auction_first_case.bbo ``` should produce something like ``` 0x60606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f37f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f00000000000000000000000000000000000000000000000000000000000000237f000000000000000000000000000000000000000000000000000000000000000055347f0000000000000000000000000000000000000000000000000000000000000005547f0000000000000000000000000000000000000000000000000000000000000003547f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000005557f00000000000000000000000000000000000000000000000000000000000000045560016020807f000000000000000000000000000000000000000000000000000000000000004080518092019052918152f360606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f3 ``` Append Arguments ---------------- The [source](../src/parse/examples/006auction_first_case.bbo) shows the signature of the contract. ``` contract auction (address _beneficiary ,uint _bidding_time ,bool[address] _bids ,uint _highest_bid) ``` Of the four arguments, the three non-array arguments `_beneficiary`, `_bidding_time` and `_highest_bid` need to be specified. Each of them take 32 bytes (even when it's an address that requires just 20 bytes). Append the arguments to the bytecode, and you will get something like ``` 0x60606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f37f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f00000000000000000000000000000000000000000000000000000000000000237f000000000000000000000000000000000000000000000000000000000000000055347f0000000000000000000000000000000000000000000000000000000000000005547f0000000000000000000000000000000000000000000000000000000000000003547f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000005557f00000000000000000000000000000000000000000000000000000000000000045560016020807f000000000000000000000000000000000000000000000000000000000000004080518092019052918152f360606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f30x60606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f37f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f00000000000000000000000000000000000000000000000000000000000000237f000000000000000000000000000000000000000000000000000000000000000055347f0000000000000000000000000000000000000000000000000000000000000005547f0000000000000000000000000000000000000000000000000000000000000003547f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000005557f00000000000000000000000000000000000000000000000000000000000000045560016020807f000000000000000000000000000000000000000000000000000000000000004080518092019052918152f360606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f3000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000200000000000000000000000000000000000000000000000000000000000000000 ``` In this hex notation, 32 bytes are represented by 64 characters. Testing the Contract on a Testnet --------------------------------- Checkout [go-ethereum](https://github.com/ethereum/go-ethereum) and build it. ``` > git clone https://github.com/ethereum/go-ethereum > cd go-ethereum > make ``` You might need to install [Go](https://golang.org). And you can run something like ``` build/bin/geth --testnet console --fast --bootnodes "enode://20c9ad97c081d63397d7b685a412227a40e23c8bdc6688c6f37e97cfbc22d2b4d1db1510d8f61e6a8866ad7f0e17c02b14182d37ea7c3c8b9c2683aeb6b733a1@52.169.14.227:30303,enode://6ce05930c72abc632c58e2e4324f7c7ea478cec0ed4fa2528982cf34483094e9cbc9216e7aa349691242576d552a2a56aaeae426c5303ded677ce455ba1acd9d@13.84.180.240:30303" ``` Below, everything is in the console of `geth`. Check if you already have an account: ``` > eth.accounts ``` If you have no accounts, create one: ``` > personal.newAccount() ``` to create an account. ``` miner.start(2) ``` to start mining. Leave the machine for half an hour. If ``` > eth.getBalance(eth.accounts[0]) ``` shows some non-zero number, you are ready to continue. I chose to perform the concatenation in the `geth` console. ``` var data = "0x60606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f37f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f00000000000000000000000000000000000000000000000000000000000000237f000000000000000000000000000000000000000000000000000000000000000055347f0000000000000000000000000000000000000000000000000000000000000005547f0000000000000000000000000000000000000000000000000000000000000003547f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000005557f00000000000000000000000000000000000000000000000000000000000000045560016020807f000000000000000000000000000000000000000000000000000000000000004080518092019052918152f360606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f3" ``` ``` var data = data+"0000000000000000000000000000000000000000000000000000000000000000"+"0000000000000000000000000000000000000000000000000000000400000020"+"0000000000000000000000000000000000000000000000000000000000000000" ``` Now I can deploy the contract. ``` var tx = eth.sendTransaction({from: eth.accounts[0], data: data, gas: 1000000}) ``` After doing this, it takes some time until you see ``` > eth.getTransactionReceipt(tx) { blockHash: "0x21ad6127030275d8ec0e0e0c6291e4a9e4a571c00e961f88e385dedeae930487", blockNumber: 1197013, contractAddress: "0x56d9ffea1224a661fc63855994638efebbf2c92b", cumulativeGasUsed: 382585, from: "0xe64ae430b97ff403a194e214175c4144a82969f4", gasUsed: 382585, logs: [], logsBloom: "0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", root: "0xb50914b39a58ef18700766cb8f49753447dee0f70a01443b5a15479908940753", to: null, transactionHash: "0xd480e58ceed4e6f2950f45ba7eec1ac9068799d6a49ecc62db97f152da2d79cb", transactionIndex: 0 } ``` And then, you can get the address of the deployed contract. ``` > var contract = eth.getTransactionReceipt(tx).contractAddress ``` Indeed, there is code. ``` > eth.getCode(contract) "0x7f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f00000000000000000000000000000000000000000000000000000000000000237f000000000000000000000000000000000000000000000000000000000000000055347f0000000000000000000000000000000000000000000000000000000000000005547f0000000000000000000000000000000000000000000000000000000000000003547f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000005557f00000000000000000000000000000000000000000000000000000000000000045560016020807f000000000000000000000000000000000000000000000000000000000000004080518092019052918152f360606040527f0000000000000000000000000000000000000000000000000000000000000060807f0000000000000000000000000000000000000000000000000000000000000040805180920190528180380382397f00000000000000000000000000000000000000000000000000000000000000025b82157f000000000000000000000000000000000000000000000000000000000000012c57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f000000000000000000000000000000000000000000000000000000000000002001907f0000000000000000000000000000000000000000000000000000000000000076565b5050506001547f000000000000000000000000000000000000000000000000000000000000015957600180555b600154806300000005557f0000000000000000000000000000000000000000000000000000000000000001016001557f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000000414807f000000000000000000000000000000000000000000000000000000000000004080518092019052817f000000000000000000000000000000000000000000000000000000000000023b8239f3" ``` And the arguments are stored in a straight-forward way ``` > eth.getStorageAt(contract, 2) "0x0000000000000000000000000000000000000000000000000000000000000000" > eth.getStorageAt(contract, 3) "0x0000000000000000000000000000000000000000000000000000000000000020" > eth.getStorageAt(contract, 4) "0x0000000000000000000000000000000000000000000000000000000000000000" ``` You can send another transaction to invoke the `default` case ``` eth.sendTransaction({from: eth.accounts[0], to: contract, data: "", value: 100}) ``` After a while, you see that the storage has changed. ``` > eth.getStorageAt(contract, 4) "0x0000000000000000000000000000000000000000000000000000000000000064" ``` ================================================ FILE: doc/tutorial.md ================================================ # Bamboo 0.0.01 Tutorial This document covers * installation of the Bamboo compiler * compilation and deployment of a Bamboo program * interaction with the deployed Ethereum contract ## Installing the Bamboo compiler Make sure OCaml 4.04 is installed ``` $ ocaml --version The OCaml toplevel, version 4.04.2 ``` If a newer version is installed get the old one [here](http://ocaml.org/releases/4.04.html) The Bamboo compiler can be installed with the OCaml package manager `opam`. If you don't have it yet, get `opam` by * `apt-get install opam` * `brew install opam` * or one of [many other ways](https://opam.ocaml.org/doc/Install.html) After installing `opam`, run `opam init` and follow the instructions. When `opam` is ready, `opam install bamboo` gets you the Bamboo compiler. ``` $ bamboo --version 0.0.01 ``` If anything goes wrong, poke @pirapira on [the Gitter channel](https://gitter.im/bbo-dev). ## Compiling Bamboo code Let's deploy [this ERC20 contract](https://github.com/pirapira/bamboo/blob/master/src/parse/examples/01b_erc20better.bbo) on the Ropsten test network. ``` $ wget https://raw.githubusercontent.com/pirapira/bamboo/master/src/parse/examples/01b_erc20better.bbo ``` will get you a file `01b_erc20better.bbo`. You can have a look now, but I'll explain the contents when we interact with the contract. Now, ``` $ bamboo < 01b_erc20better.bbo > compiled.hex ``` should store something in `compiled.hex` file. You can have a look. If you use it for anything serious, you should investigate `compiled.hex` here. Since we are just playing on the test network, we go ahead deploying the compiled code. Also, ``` $ bamboo --abi < 01b_erc20better.bbo > abi.json ``` will get you a JSON file `abi.json` that describes the interface of this Ethereum contract. ## Deploying on the Ropsten test network The Ropsten network is a test network for Ethereum. The balances and accounts are cleared sometimes. In this tutorial we deploy the code to Ropsten. ### Connecting go-ethereum to the Ropsten network We use `go-ethereum`. [Install go-ethereum](https://ethereum.github.io/go-ethereum/install/) somehow and run ``` $ build/bin/geth console --testnet --fast --bootnodes "enode://20c9ad97c081d63397d7b685a412227a40e23c8bdc6688c6f37e97cfbc22d2b4d1db1510d8f61e6a8866ad7f0e17c02b14182d37ea7c3c8b9c2683aeb6b733a1@52.169.14.227:30303,enode://6ce05930c72abc632c58e2e4324f7c7ea478cec0ed4fa2528982cf34483094e9cbc9216e7aa349691242576d552a2a56aaeae426c5303ded677ce455ba1acd9d@13.84.180.240:30303" ``` When you are still seeing something like ``` INFO [08-02|14:00:28] Imported new chain segment blocks=119 txs=324 mgas=130.952 elapsed=8.008s mgasps=16.352 number=1375400 hash=cd3c3f…a39ed3 ``` with `blocks=119` or some big numbers, `go-ethereum` has not synced yet. When it's synced, you will be seeing `blocks=1` ``` INFO [08-02|14:22:16] Imported new chain segment blocks=1 txs=0 mgas=0.000 elapsed=13.958ms mgasps=0.000 number=1417137 hash=8603a5…1de724 ``` ### Creating an account For deploying code on the Ropsten network, you need an account. If you don't have one, you can create it by typing ``` > personal.newAccount() ``` into the geth console. ### Earning some Ropsten test Ether For deploying code on the Ropsten network, you also need Ropsten Ether. You can either mine it, or get it from somebody else. You can check your first account's balance by ``` > eth.getBalance(eth.accounts[0]) 2991644430772416863 ``` in the geth console. If it shows zero, there are ways to earn Ropsten Ether. #### Option 1. mining You can start mining Ropsten Ether ``` > miner.start(2) ``` Usually you will get some Ropsten Ether within some hours. When you have some non-zero number, you can stop the mining by ``` > miner.stop() ``` on the geth console. #### Option 2. asking If you know somebody with Ropsten Ether, you can tell them your address created above, and ask them to send you some Ropsten Ether. You can find your address by typing ``` > eth.accounts[0] ``` ### Preparing the code and the ABI Now you can give a name to the hex code in `compiled.hex`. ``` > var code = "0x60606040527f0000000000000000000000000000000000000000000000000000000000000020806040805180920190528180380382397f0000000000000000000000000000000000000000000000000000000000003dd13814156002577f00000000000000000000000000000000000000000000000000000000000000025b821563000000fc57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f00000000000000000000000000000000000000000000000000000000000000200190630000007e565b505050600154630000010d57600180555b6300000003630000014857600154806300000003557f0000000000000000000000000000000000000000000000000000000000000001016001555b6300000004630000018357600154806300000004557f0000000000000000000000000000000000000000000000000000000000000001016001555b7f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000003b9a80604080518092019052817f00000000000000000000000000000000000000000000000000000000000002178239f37f000000000000000000000000000000000000000000000000000000000000000054565b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004507f0000000000000000000000000000000000000000000000000000000000000075565b7f000000000000000000000000000000000000000000000000000000000000000254307f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000012c57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020557f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000020f57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000002a357507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455005b60606040527f00000000000000000000000000000000000000000000000000000000000000003560e060020a9004806318160ddd147f00000000000000000000000000000000000000000000000000000000000004a857806370a08231147f00000000000000000000000000000000000000000000000000000000000006da578063a9059cbb147f0000000000000000000000000000000000000000000000000000000000000997578063095ea7b3147f00000000000000000000000000000000000000000000000000000000000012e8578063dd62ed3e147f000000000000000000000000000000000000000000000000000000000000178e57806323b872dd147f0000000000000000000000000000000000000000000000000000000000001b45578063d96a094a147f0000000000000000000000000000000000000000000000000000000000002867578063d79875eb147f000000000000000000000000000000000000000000000000000000000000301057506002565b63000000043614156000577f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000058a57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000061e57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f0000000000000000000000000000000000000000000000000000000000000004557f00000000000000000000000000000000000000000000000000000000000000025460208060408051809201905291825290f35b63000000243614156000577f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f00000000000000000000000000000000000000000000000000000000000007bc57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000085057507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000097957507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205460208060408051809201905291825290f35b6300000044361415600057630000002435337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000a3d57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205410156300000a55576002565b630000001035606060020a90043314156300000c9857333363ddf252ad630000002435602080604080518092019052918252909060006000500190a37f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000000b6857507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000bfc57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b630000002435337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000d3357507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205403337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000dd557507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000e8257507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054630000002435630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000f3557507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020540110156300000f4e576002565b630000002435630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000000ff557507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205401630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000010a357507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000001035606060020a90043363ddf252ad630000002435602080604080518092019052918252909060006000500190a37f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f00000000000000000000000000000000000000000000000000000000000011b857507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000124c57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b6300000044361415600057630000002435337f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000138e57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054101563000013a6576002565b630000001035606060020a900433141563000013c0576002565b630000002435630000001035606060020a9004337f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000146857507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020548063000015495750337f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000151157507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000001035606060020a900433638c5be1e5630000002435602080604080518092019052918252909060006000500190a37f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000165e57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000016f257507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b63000000443614156000577f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000187057507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000190457507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455630000003035606060020a9004630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000001a3a57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054806300001b275750630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000001aef57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205460208060408051809201905291825290f35b6300000064361415600057630000004435630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000001bf757507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205410156300001c0f576002565b63000000443533630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000001cb757507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054806300001da45750630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000001d6c57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205410156300001dbc576002565b630000003035606060020a9004630000001035606060020a90041415630000202357630000003035606060020a9004630000001035606060020a900463ddf252ad630000004435602080604080518092019052918252909060006000500190a37f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000001ef357507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000001f8757507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b630000004435630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000020ca57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205403630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000217857507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205563000000443533630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000222c57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020548063000023195750630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f00000000000000000000000000000000000000000000000000000000000022e157507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020540333630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f00000000000000000000000000000000000000000000000000000000000023c857507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020548063000024b55750630000001035606060020a90047f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000247d57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000004435630000003035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000256857507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205401630000003035606060020a90047f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000261657507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000003035606060020a9004630000001035606060020a900463ddf252ad630000004435602080604080518092019052918252909060006000500190a37f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000273757507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000027cb57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b6300000024361415600057630000000435307f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000290d57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205410156300002925576002565b337f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000029ba57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054630000000435337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002a6157507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020540110156300002a7a576002565b3430310334630000000435307f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002b1a57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054030263000000043530310211156300002b3d576002565b630000000435307f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002bd857507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205403307f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002c7a57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000000435337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002d2157507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205401337f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002dc357507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205533631cbc5ab1630000000435602080604080518092019052918252909034602080604080518092019052918252909060006000500190500190a27f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f0000000000000000000000000000000000000000000000000000000000002ee057507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f0000000000000000000000000000000000000000000000000000000000002f7457507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f35b630000004436141560005763000000243530311015630000302f576002565b630000000435337f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000030ca57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054101563000030e2576002565b307f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000317757507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054630000000435307f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000321e57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020540110156300003237576002565b341515156300003245576002565b3031630000002435303103630000000435307f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000032eb57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002054016300000024358102630000000435830210156300003314576002565b80307f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000033aa57507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b600052602052604060002055630000000435337f000000000000000000000000000000000000000000000000000000000000000354807f000000000000000000000000000000000000000000000000000000000000345157507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b60005260205260406000205403337f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000034f357507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b6000526020526040600020553363ed7a144f6300000004356020806040805180920190529182529090630000002435602080604080518092019052918252909060006000500190500190a26000546000805560008081818181630000002435336300000bb85a03f1156000579160005550507f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f000000000000000000000000000000000000000000000000000000000000000454807f000000000000000000000000000000000000000000000000000000000000363c57507f0000000000000000000000000000000000000000000000000000000000000004600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f000000000000000000000000000000000000000000000000000000000000000354807f00000000000000000000000000000000000000000000000000000000000036d057507f0000000000000000000000000000000000000000000000000000000000000003600154807f0000000000000000000000000000000000000000000000000000000000000001016001558091555b7f0000000000000000000000000000000000000000000000000000000000000002547f0000000000000000000000000000000000000000000000000000000000000002557f0000000000000000000000000000000000000000000000000000000000000003557f000000000000000000000000000000000000000000000000000000000000000455600160208060408051809201905291825290f360606040527f0000000000000000000000000000000000000000000000000000000000000020806040805180920190528180380382397f0000000000000000000000000000000000000000000000000000000000003dd13814156002577f00000000000000000000000000000000000000000000000000000000000000025b821563000000fc57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f00000000000000000000000000000000000000000000000000000000000000200190630000007e565b505050600154630000010d57600180555b6300000003630000014857600154806300000003557f0000000000000000000000000000000000000000000000000000000000000001016001555b6300000004630000018357600154806300000004557f0000000000000000000000000000000000000000000000000000000000000001016001555b7f00000000000000000000000000000000000000000000000000000000000000237f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000003b9a80604080518092019052817f00000000000000000000000000000000000000000000000000000000000002178239f360606040527f0000000000000000000000000000000000000000000000000000000000000020806040805180920190528180380382397f0000000000000000000000000000000000000000000000000000000000003dd13814156002577f00000000000000000000000000000000000000000000000000000000000000025b821563000000fc57815181557f0000000000000000000000000000000000000000000000000000000000000020909203917f000000000000000000000000000000000000000000000000000000000000000101907f00000000000000000000000000000000000000000000000000000000000000200190630000007e565b505050600154630000010d57600180555b6300000003630000014857600154806300000003557f0000000000000000000000000000000000000000000000000000000000000001016001555b6300000004630000018357600154806300000004557f0000000000000000000000000000000000000000000000000000000000000001016001555b7f000000000000000000000000000000000000000000000000000000000000032d7f0000000000000000000000000000000000000000000000000000000000000000557f0000000000000000000000000000000000000000000000000000000000003b9a80604080518092019052817f00000000000000000000000000000000000000000000000000000000000002178239f3" ``` Now console session remembers the code. ``` > code ``` should show the same string. (If you don't want to copy-and-paste strings, probably you should look at the [web3](https://github.com/ethereum/web3.js/) library.) Also, we can store the abi in `abi.json`. ``` var abi = [{"type": "constructor", "inputs":[{"name": "totalSupply", "type": "uint256"}], "name": "PreToken", "outputs":[], "payable": true},{"type":"fallback","inputs": [],"outputs": [],"payable": true},{"type":"event","inputs":[{"name":"_from","type":"address","indexed":true},{"name":"_to","type":"address","indexed":true},{"name":"_amount","type":"uint256","indexed":false}],"name":"Transfer"},{"type":"event","inputs":[{"name":"_buyer","type":"address","indexed":true},{"name":"_amount","type":"uint256","indexed":false},{"name":"_value","type":"uint256","indexed":false}],"name":"Buy"},{"type":"event","inputs":[{"name":"_buyer","type":"address","indexed":true},{"name":"_amount","type":"uint256","indexed":false},{"name":"_value","type":"uint256","indexed":false}],"name":"Sell"},{"type":"event","inputs":[{"name":"_owner","type":"address","indexed":true},{"name":"_spender","type":"address","indexed":true},{"name":"_value","type":"uint256","indexed":false}],"name":"Approval"},{"type":"function","name":"totalSupply","inputs": [],"outputs": [{"name": "", "type": "uint256"}],"payable": true},{"type":"function","name":"balanceOf","inputs": [{"name": "a", "type": "address"}],"outputs": [{"name": "", "type": "uint256"}],"payable": true},{"type":"function","name":"transfer","inputs": [{"name": "_to", "type": "address"},{"name": "_amount", "type": "uint256"}],"outputs": [{"name": "", "type": "bool"}],"payable": true},{"type":"function","name":"approve","inputs": [{"name": "_spender", "type": "address"},{"name": "_amount", "type": "uint256"}],"outputs": [{"name": "", "type": "bool"}],"payable": true},{"type":"function","name":"allowance","inputs": [{"name": "_owner", "type": "address"},{"name": "_spender", "type": "address"}],"outputs": [{"name": "", "type": "uint256"}],"payable": true},{"type":"function","name":"transferFrom","inputs": [{"name": "_from", "type": "address"},{"name": "_to", "type": "address"},{"name": "_amount", "type": "uint256"}],"outputs": [{"name": "", "type": "bool"}],"payable": true},{"type":"function","name":"buy","inputs": [{"name": "_amount", "type": "uint256"}],"outputs": [{"name": "", "type": "bool"}],"payable": true},{"type":"function","name":"sell","inputs": [{"name": "_amount", "type": "uint256"},{"name": "_value", "type": "uint256"}],"outputs": [{"name": "", "type": "bool"}],"payable": true}] ``` ### Preparing the initial arguments When you deploy the code, the contract first becomes the `PreToken` contract. ``` contract PreToken (uint256 totalSupply ,address => uint256 balances ,address => address => uint256 allowances ) { } ``` The `PreToken` contract has three arguments `totalSupply`, `balances`, and `allowances`. However, when you deploy the code, you can only specify `totalSupply` because the other arguments are mappings (TODO: document mappings and add a link here). Let's say we want the `totalSupply` to be `2^30`. The argument needs to be in hex (without `0x`) and 64 characters (representing 32 bytes = 1 word in Ethereum). ``` var totalSupply = "0000000000000000000000000000000000000000000000000000000040000000" ``` You can check the length of `totalSupply` like this: ``` > totalSupply.length 64 ``` If you have a different number, the contract will not be deployed. When we concatenate the code and the argument, we get the initialization data. ``` var initdata = code + totalSupply ``` ### Unlocking the Account In order to deploy code, you need an unlocked account with positive balance. ``` > personal.unlockAccount(eth.accounts[0]) ``` ### Deploying the contract ``` > var tx = eth.sendTransaction({from: eth.accounts[0], data: initdata, gas: 4000000}) ``` For the beginning, while the transaction is not included in the blockchain yet, you see ``` > eth.getTransactionReceipt(tx) null ``` After a while, you will see something like ``` > eth.getTransactionReceipt(tx) { blockHash: "0x00b34e48533b402b212b8278a06cd8455779af02eb213ca125e2cb0a67176d0c", blockNumber: 1417246, contractAddress: "0x624b4eab5c2dadc2e6db2e3517b0623d3bb15a68", cumulativeGasUsed: 3486372, from: "0xe64ae430b97ff403a194e214175c4144a82969f4", gasUsed: 3486372, logs: [], logsBloom: "0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", root: "0xfeeace094af32de1843304a2e50942a20e86275e97566b42da82aa5cc0d56f91", to: null, transactionHash: "0x3a8bb995cfd33af80d3a65d29f5c6906bb6759cde65824988fea3bb5794caaf4", transactionIndex: 0 } ``` Now the Ethereum contract has been deployed on the Ropsten network! ## Interacting with the Ethereum contract The Ethereum contract is deployed at a certain address. ``` var contractAddress = eth.getTransactionReceipt(tx).contractAddress ``` You can get an object representing the Ethereum contract. ``` var contract = eth.contract(abi).at(contractAddress) ``` Now remember that the contract is currently a `PreToken`: ``` contract PreToken (uint256 totalSupply ,address => uint256 balances ,address => address => uint256 allowances ) { default { balances[this] = totalSupply; return then become Token(totalSupply, balances, allowances); } } ``` As the source code reads, `PreToken` `become`s a `Token` contract when it is called with enough gas. Now let's just try to do that. ``` > eth.sendTransaction({from: eth.accounts[0], to: contractAddress, gas:3000000}) ``` You might need to unlock the account. After that, the contract becomes a `Token` contract. ``` contract Token (uint256 totalSupply ,address => uint256 balances ,address => address => uint256 allowances ) { case(uint256 totalSupply()) { } case(uint256 balanceOf(address a)) { } case(bool transfer(address _to, uint256 _amount)) { } case(bool approve(address _spender, uint256 _amount)) { } case(uint256 allowance(address _owner, address _spender)) { } case(bool transferFrom(address _from, address _to, uint256 _amount)) { } case(bool buy(uint256 _amount)) { } case (bool sell(uint256 _amount, uint256 _value)) { } } ``` You don't have a balance in this ERC20 contract yet, so you can only `buy` the ERC20 token you have just created. Say you want to buy 100 tokens with 500 wei. ``` > contract.buy(100, {from: eth.accounts[0], value: 500}) ``` After a while, you will see the balance ``` > contract.balanceOf.call(eth.accounts[0]) 100 ``` Now you can use the other methods as well. Try `transfer()` perhaps. ================================================ FILE: myocamlbuild.ml ================================================ (* OASIS_START *) (* DO NOT EDIT (digest: 9311c1947cc1275785273cf40407014e) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; !what_idx = String.length what let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; !what_idx = -1 let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (compare_csl s1 s2) = 0 let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in OASISString.lowercase_ascii buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt let rec file_location ?pos1 ?pos2 ?lexbuf () = match pos1, pos2, lexbuf with | Some p, None, _ | None, Some p, _ -> file_location ~pos1:p ~pos2:p ?lexbuf () | Some p1, Some p2, _ -> let open Lexing in let fn, lineno = p1.pos_fname, p1.pos_lnum in let c1 = p1.pos_cnum - p1.pos_bol in let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 | _, _, Some lexbuf -> file_location ~pos1:(Lexing.lexeme_start_p lexbuf) ~pos2:(Lexing.lexeme_end_p lexbuf) () | None, None, None -> s_ "" let failwithpf ?pos1 ?pos2 ?lexbuf fmt = let loc = file_location ?pos1 ?pos2 ?lexbuf () in Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext open OASISUtils type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 437 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = let line = ref 1 in let lexer st = let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in Genlex.make_lexer ["="] st_line in let rec read_file lxr mp = match Stream.npeek 3 lxr with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; read_file lxr (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in match stream with | Some st -> read_file (lexer st) MapString.empty | None -> if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in try let mp = read_file (lexer st) MapString.empty in close_in chn; mp with e -> close_in chn; raise e end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 517 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html * by N. Pouillard and others * * Updated on 2016-06-02 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin type conf = {no_automatic_syntax: bool} let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = let env = BaseEnvLight.load ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* Avoid warnings for unused tag *) flag ["tests"] N; (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if not (conf.no_automatic_syntax) && (Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax) then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 878 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("cross-platform", ["src/cross-platform-for-ocamlbuild"], []); ("basics", ["src/basics"], []); ("ast", ["src/ast"], []); ("parse", ["src/parse"], []); ("codegen", ["src/codegen"], []) ]; lib_c = []; flags = []; includes = [ ("src/parse", ["src/ast"]); ("src/exec", ["src/codegen"; "src/parse"]); ("src/codegen", ["src/ast"; "src/basics"; "src/parse"]); ("src/basics", ["src/cross-platform-for-ocamlbuild"]); ("src/ast", ["src/basics"]) ] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 908 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; ================================================ FILE: opam/descr ================================================ A compiler targeting Ethereum Virtual Machine Bamboo compiles a simple language to Ethereum Virtual Machine. The language is designed to keep programmers away from common mistakes. It features: state transition as recursion with potentially changing arguments, mandatory reentrance continuation when calling out, no loops, no assignments except to mappings and partial compliance with common Ethereum ABI. ================================================ FILE: opam/opam ================================================ opam-version: "1.2" maintainer: "Yoichi Hirai " authors: "Yoichi Hirai " name: "bamboo" version: "0.0.03" homepage: "https://github.com/pirapira/bamboo" bug-reports: "https://github.com/pirapira/bamboo/issues" license: "Apache-2.0" dev-repo: "https://github.com/pirapira/bamboo.git" build: [ [ "rm" "-f" "src/parse/parser.ml" "src/parse/parser.mli" "src/parse/lexer.ml" ] ["ocaml" "setup.ml" "-configure" "--prefix" prefix] ["ocaml" "setup.ml" "-build"] ] install: ["ocaml" "setup.ml" "-install"] build-test: [ ["ocaml" "setup.ml" "-configure" "--enable-tests"] ["ocaml" "setup.ml" "-build"] ["ocaml" "setup.ml" "-test"] ] remove: ["ocamlfind" "remove" "bamboo"] depends: [ "batteries" {build} "cryptokit" {build & >= "1.12"} "hex" {build & >= "0.1.0" & <= "1.0.0"} "menhir" {build & >= "20120123" & <= "20151005"} "ocamlbuild" {build & (>= "0.9.3" | = "0")} "ocamlfind" {build} "rope" {build} ] ================================================ FILE: package.json ================================================ { "name": "bamboo", "version": "0.0.02", "description": "A compiler targeting Ethereum Virtual Machine", "keywords": [ "ethereum", "smart-contracts", "blockchain", "virtual machine", "compiler" ], "repository": { "type": "git", "url": "https://github.com/pirapira/bamboo" }, "homepage": "https://github.com/pirapira/bamboo", "author": "Yoichi Hirai ", "license": "Apache-2.0", "devDependencies": { "bs-platform": "bsansouci/bsb-native#2.1.1" }, "scripts": { "build": "bsb -make-world -backend native", "build-js": "bsb -make-world -backend js", "watch": "bsb -make-world -backend native -w", "test": "npm run build && ./lib/bs/native/test.native", "clean": "bsb -clean-world" }, "dependencies": { "bn.js": "^4.11.8", "bs-bn.js": "0.0.2", "keccak": "^1.4.0" } } ================================================ FILE: setup.ml ================================================ (* setup.ml generated for the first time by OASIS v0.4.10 *) (* OASIS_START *) (* DO NOT EDIT (digest: e49f9499c8ae75ca2ab01e5d5fc622dd) *) (* Regenerated by OASIS v0.4.10 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; !what_idx = String.length what let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; !what_idx = -1 let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf let lowercase_ascii = replace_chars (fun c -> if (c >= 'A' && c <= 'Z') then Char.chr (Char.code c + 32) else c) let uncapitalize_ascii s = if s <> "" then (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s let uppercase_ascii = replace_chars (fun c -> if (c >= 'a' && c <= 'z') then Char.chr (Char.code c - 32) else c) let capitalize_ascii s = if s <> "" then (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) else s end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (compare_csl s1 s2) = 0 let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in OASISString.lowercase_ascii buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt let rec file_location ?pos1 ?pos2 ?lexbuf () = match pos1, pos2, lexbuf with | Some p, None, _ | None, Some p, _ -> file_location ~pos1:p ~pos2:p ?lexbuf () | Some p1, Some p2, _ -> let open Lexing in let fn, lineno = p1.pos_fname, p1.pos_lnum in let c1 = p1.pos_cnum - p1.pos_bol in let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 | _, _, Some lexbuf -> file_location ~pos1:(Lexing.lexeme_start_p lexbuf) ~pos2:(Lexing.lexeme_end_p lexbuf) () | None, None, None -> s_ "" let failwithpf ?pos1 ?pos2 ?lexbuf fmt = let loc = file_location ?pos1 ?pos2 ?lexbuf () in Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.capitalize_ascii base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (OASISString.uncapitalize_ascii base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename open OASISGettext module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = match Sys.os_type with | "Unix" | "Cygwin" -> ufn | "Win32" -> make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) | os_type -> OASISUtils.failwithf (f_ "Don't know the path format of os_type %S when translating unix \ filename. %S") os_type ufn end module OASISFileSystem = struct (* # 22 "src/oasis/OASISFileSystem.ml" *) (** File System functions @author Sylvain Le Gall *) type 'a filename = string class type closer = object method close: unit end class type reader = object inherit closer method input: Buffer.t -> int -> unit end class type writer = object inherit closer method output: Buffer.t -> unit end class type ['a] fs = object method string_of_filename: 'a filename -> string method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader method file_exists: 'a filename -> bool method remove: 'a filename -> unit end module Mode = struct let default_in = [Open_rdonly] let default_out = [Open_wronly; Open_creat; Open_trunc] let text_in = Open_text :: default_in let text_out = Open_text :: default_out let binary_in = Open_binary :: default_in let binary_out = Open_binary :: default_out end let std_length = 4096 (* Standard buffer/read length. *) let binary_out = Mode.binary_out let binary_in = Mode.binary_in let of_unix_filename ufn = (ufn: 'a filename) let to_unix_filename fn = (fn: string) let defer_close o f = try let r = f o in o#close; r with e -> o#close; raise e let stream_of_reader rdr = let buf = Buffer.create std_length in let pos = ref 0 in let eof = ref false in let rec next idx = let bpos = idx - !pos in if !eof then begin None end else if bpos < Buffer.length buf then begin Some (Buffer.nth buf bpos) end else begin pos := !pos + Buffer.length buf; Buffer.clear buf; begin try rdr#input buf std_length; with End_of_file -> if Buffer.length buf = 0 then eof := true end; next idx end in Stream.from next let read_all buf rdr = try while true do rdr#input buf std_length done with End_of_file -> () class ['a] host_fs rootdir : ['a] fs = object (self) method private host_filename fn = Filename.concat rootdir fn method string_of_filename = self#host_filename method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = let chn = open_out_gen mode perm (self#host_filename fn) in object method close = close_out chn method output buf = Buffer.output_buffer chn buf end method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = (* TODO: use Buffer.add_channel when minimal version of OCaml will * be >= 4.03.0 (previous version was discarding last chars). *) let chn = open_in_gen mode perm (self#host_filename fn) in let strm = Stream.of_channel chn in object method close = close_in chn method input buf len = let read = ref 0 in try for _i = 0 to len do Buffer.add_char buf (Stream.next strm); incr read done with Stream.Failure -> if !read = 0 then raise End_of_file end method file_exists fn = Sys.file_exists (self#host_filename fn) method remove fn = Sys.remove (self#host_filename fn) end end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type source type source_filename = source OASISFileSystem.filename let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; srcfs: source OASISFileSystem.fs; load_oasis_plugin: string -> bool; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); load_oasis_plugin = (fun _ -> false); } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", Arg.String (fun str -> Sys.chdir str; default := {!default with srcfs = new OASISFileSystem.host_fs str}), s_ "dir Change directory before running (affects setup.{data,log})."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 77 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then OASISString.lowercase_ascii else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext open OASISUtils type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISSourcePatterns = struct (* # 22 "src/oasis/OASISSourcePatterns.ml" *) open OASISUtils open OASISGettext module Templater = struct (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) type t = { atoms: atom list; origin: string } and atom = | Text of string | Expr of expr and expr = | Ident of string | String of string | Call of string * expr type env = { variables: string MapString.t; functions: (string -> string) MapString.t; } let eval env t = let rec eval_expr env = function | String str -> str | Ident nm -> begin try MapString.find nm env.variables with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find variable %S in source pattern %S") nm t.origin end | Call (fn, expr) -> begin try (MapString.find fn env.functions) (eval_expr env expr) with Not_found -> (* TODO: add error location within the string. *) failwithf (f_ "Unable to find function %S in source pattern %S") fn t.origin end in String.concat "" (List.map (function | Text str -> str | Expr expr -> eval_expr env expr) t.atoms) let parse env s = let lxr = Genlex.make_lexer [] in let parse_expr s = let st = lxr (Stream.of_string s) in match Stream.npeek 3 st with | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) | [Genlex.String str] -> String str | [Genlex.Ident nm] -> Ident nm (* TODO: add error location within the string. *) | _ -> failwithf (f_ "Unable to parse expression %S") s in let parse s = let lst_exprs = ref [] in let ss = let buff = Buffer.create (String.length s) in Buffer.add_substitute buff (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") s; Buffer.contents buff in let rec join = function | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) | [], tl -> List.map (fun e -> Expr e) tl | tl, [] -> List.map (fun e -> Text e) tl in join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) in let t = {atoms = parse s; origin = s} in (* We rely on a simple evaluation for checking variables/functions. It works because there is no if/loop statement. *) let _s : string = eval env t in t (* # 144 "src/oasis/OASISSourcePatterns.ml" *) end type t = Templater.t let env ~modul () = { Templater. variables = MapString.of_list ["module", modul]; functions = MapString.of_list [ "capitalize_file", OASISUnixPath.capitalize_file; "uncapitalize_file", OASISUnixPath.uncapitalize_file; ]; } let all_possible_files lst ~path ~modul = let eval = Templater.eval (env ~modul ()) in List.fold_left (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) [] lst let to_string t = t.Templater.origin end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string (* TODO: replace everywhere. *) type host_dirname = string (* TODO: replace everywhere. *) type host_filename = string (* TODO: replace everywhere. *) type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_interface_patterns: OASISSourcePatterns.t list; bs_implementation_patterns: OASISSourcePatterns.t list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_findlib_extra_files: unix_filename list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_directory: unix_dirname option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; obj_findlib_directory: unix_dirname option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename (* TODO: source filename. *) | DocText | PDF | PostScript | Info of unix_filename (* TODO: source filename. *) | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; (* TODO: dest filename ?. *) doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; (* TODO: src filename. *) doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; (* TODO: source filename. *) copyrights: string list; maintainers: string list; authors: string list; homepage: url option; bugreports: url option; synopsis: string; description: OASISText.t option; tags: string list; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; (* TODO: source filename. *) sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; (* TODO: source filename. *) schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version (t:t).oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" (t:t).name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem (t:t).name features in if not has_feature then match (origin:origin) with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some _ -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Make building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Make running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "Compile the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allow the OASIS section comments and digests to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") let findlib_directory = create "findlib_directory" beta (fun () -> s_ "Allow to install findlib libraries in sub-directories of the target \ findlib directory.") let findlib_extra_files = create "findlib_extra_files" beta (fun () -> s_ "Allow to install extra files for findlib libraries.") let source_patterns = create "source_patterns" alpha (fun () -> s_ "Customize mapping between module name and source file.") end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section_kind = function | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc" let string_of_section sct = let k, nm = section_id sct in (string_of_section_kind k)^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) open OASISTypes (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_lst = OASISSourcePatterns.all_possible_files (bs.bs_interface_patterns @ bs.bs_implementation_patterns) ~path:bs.bs_path ~modul in match List.filter source_file_exists possible_lst with | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) | [] -> let open OASISUtils in let _, rev_lst = List.fold_left (fun (set, acc) fn -> let base_fn = OASISUnixPath.chop_extension fn in if SetString.mem base_fn set then set, acc else SetString.add base_fn set, base_fn :: acc) (SetString.empty, []) possible_lst in `No_sources (List.rev rev_lst) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in library %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (_, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map (List.fold_left (fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu) []) (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: if has_native_dynlink then ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath else acc_nopath end else begin acc_nopath end in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let find_module ~ctxt source_file_exists cs bs modul = match OASISBuildSection.find_module source_file_exists bs modul with | `Sources _ as res -> res | `No_sources _ as res -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching module '%s' in object %s.") modul cs.cs_name; OASISMessage.warning ~ctxt (f_ "Use InterfacePatterns or ImplementationPatterns to define \ this file with feature %S.") (OASISFeatures.source_patterns.OASISFeatures.name); res let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match find_module ~ctxt source_file_exists cs bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * unix_dirname option * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let unix_directory dn lib = let directory = match lib with | `Library lib -> lib.lib_findlib_directory | `Object obj -> obj.obj_findlib_directory in match dn, directory with | None, None -> None | None, Some dn | Some dn, None -> Some dn | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) in let rec group_of_tree dn mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) | Node (None, children) -> Container (nm, group_of_tree dn children) | Leaf (cs, bs, lib) -> let current_dn = unix_directory dn lib in Package (nm, cs, bs, lib, current_dn, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree None group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 3159 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = let line = ref 1 in let lexer st = let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in Genlex.make_lexer ["="] st_line in let rec read_file lxr mp = match Stream.npeek 3 lxr with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; read_file lxr (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in match stream with | Some st -> read_file (lexer st) MapString.empty | None -> if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in try let mp = read_file (lexer st) MapString.empty in close_in chn; mp with e -> close_in chn; raise e end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 3239 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open OASISContext open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (_, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context:_ x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (_: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = in_srcdir "setup.data" let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = let open OASISFileSystem in env_from_file := let repr_filename = ctxt.srcfs#string_of_filename filename in if ctxt.srcfs#file_exists filename then begin let buf = Buffer.create 13 in defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (read_all buf); defer_close (ctxt.srcfs#open_in ~mode:binary_in filename) (fun rdr -> OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; BaseEnvLight.load ~allow_empty ~filename:(repr_filename) ~stream:(stream_of_reader rdr) ()) end else if allow_empty then begin BaseEnvLight.MapString.empty end else begin failwith (Printf.sprintf (f_ "Unable to load environment, the file '%s' doesn't exist.") repr_filename) end let unload () = env_from_file := MapString.empty; Data.clear env let dump ~ctxt ?(filename=default_filename) () = let open OASISFileSystem in defer_close (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) (fun wrtr -> let buf = Buffer.create 63 in let output nm value = Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try output nm (Schema.get schema env nm) with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; wrtr#output buf) let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration:\n"; List.iter (fun (name, value) -> Printf.printf "%s: %s" name (dot_pad name); if value = "" then Printf.printf "\n" else Printf.printf " %s\n" value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" || os_type () = "Cygwin" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage open OASISContext let to_filename fn = if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; OASISFileSystem.of_unix_filename (Filename.chop_extension fn) let replace ~ctxt fn_lst = let open OASISFileSystem in let ibuf, obuf = Buffer.create 13, Buffer.create 13 in List.iter (fun fn -> Buffer.clear ibuf; Buffer.clear obuf; defer_close (ctxt.srcfs#open_in (of_unix_filename fn)) (read_all ibuf); Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); defer_close (ctxt.srcfs#open_out (to_filename fn)) (fun wrtr -> wrtr#output obuf)) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils open OASISContext open OASISGettext open OASISFileSystem let default_filename = in_srcdir "setup.log" let load ~ctxt () = let module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) in if ctxt.srcfs#file_exists default_filename then begin defer_close (ctxt.srcfs#open_in default_filename) (fun rdr -> let line = ref 1 in let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in let rec read_aux (st, lst) = match Stream.npeek 2 lxr with | [Genlex.String e; Genlex.String d] -> let t = e, d in Stream.junk lxr; Stream.junk lxr; if SetTupleString.mem t st then read_aux (st, lst) else read_aux (SetTupleString.add t st, t :: lst) | [] -> List.rev lst | _ -> failwithf (f_ "Malformed log file '%s' at line %d") (ctxt.srcfs#string_of_filename default_filename) !line in read_aux (SetTupleString.empty, [])) end else begin [] end let register ~ctxt event data = defer_close (ctxt.srcfs#open_out ~mode:[Open_append; Open_creat; Open_text] ~perm:0o644 default_filename) (fun wrtr -> let buf = Buffer.create 13 in Printf.bprintf buf "%S %S\n" event data; wrtr#output buf) let unregister ~ctxt event data = let lst = load ~ctxt () in let buf = Buffer.create 13 in List.iter (fun (e, d) -> if e <> event || d <> data then Printf.bprintf buf "%S %S\n" e d) lst; if Buffer.length buf > 0 then defer_close (ctxt.srcfs#open_out default_filename) (fun wrtr -> wrtr#output buf) else ctxt.srcfs#remove default_filename let filter ~ctxt events = let st_events = SetString.of_list events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ~ctxt ()) let exists ~ctxt event data = List.exists (fun v -> (event, data) = v) (load ~ctxt ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register ~ctxt t nm lst = BaseLog.register ~ctxt (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register ~ctxt (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else begin registered end) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister ~ctxt t nm = List.iter (fun (e, d) -> BaseLog.unregister ~ctxt e d) (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) let fold ~ctxt t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter ~ctxt [to_log_event_file t nm]) let is_built ~ctxt t nm = List.fold_left (fun _ (_, d) -> try bool_of_string d with _ -> false) false (BaseLog.filter ~ctxt [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init ~ctxt pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, _) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let test ~ctxt lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin ~ctxt pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc ~ctxt lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin ~ctxt pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open OASISContext open BaseEnv open BaseMessage open OASISTypes open OASISGettext open OASISUtils type std_args_fun = ctxt:OASISContext.t -> package -> string array -> unit type ('a, 'b) section_args_fun = name * (ctxt:OASISContext.t -> package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure ~ctxt t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load ~ctxt (); with _ -> () end; (* Run plugin's configure *) t.configure ~ctxt t.package args; (* Dump to allow postconf to change it *) dump ~ctxt ()) (); (* Reload environment *) unload (); load ~ctxt (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace ~ctxt t.package.files_ab let build ~ctxt t args = BaseCustom.hook t.package.build_custom (t.build ~ctxt t.package) args let doc ~ctxt t args = BaseDoc.doc ~ctxt (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test ~ctxt t args = BaseTest.test ~ctxt (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all ~ctxt t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure ~ctxt t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build ~ctxt t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init ~ctxt t.package; if not !rno_doc then begin info "Running doc step"; doc ~ctxt t [||] end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test ~ctxt t [||] end else begin info "Skipping test step" end let install ~ctxt t args = BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args let uninstall ~ctxt t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args let reinstall ~ctxt t args = uninstall ~ctxt t args; install ~ctxt t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean ~ctxt t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun ~ctxt:_ _ _ _ -> () in failsafe (f ~ctxt t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) () in let clean ~ctxt t args = generic_clean ~ctxt t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean ~ctxt t args = (* Call clean *) clean ~ctxt t args; (* Call distclean code *) generic_clean ~ctxt t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated source files. *) List.iter (fun fn -> if ctxt.srcfs#file_exists fn then begin info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); ctxt.srcfs#remove fn end) ([BaseEnv.default_filename; BaseLog.default_filename] @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") (* TODO: srcfs *) let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (fun n -> if n <> 0 then failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in let act_ref = ref (fun ~ctxt:_ _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in try let () = Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n") in (* Instantiate the context. *) let ctxt = !BaseContext.default in (* Build initial environment *) load ~ctxt ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init ~ctxt t.package; if not (t.setup_update && update_setup_ml t) then !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end module BaseCompat = struct (* # 22 "src/base/BaseCompat.ml" *) (** Compatibility layer to provide a stable API inside setup.ml. This layer allows OASIS to change in between minor versions (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This enables to write functions that manipulate setup_t inside setup.ml. See deps.ml for an example. The module opened by default will depend on the version of the _oasis. E.g. if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and the function Compat_0_3 will be called. If setup.ml is generated with the -nocompat, no module will be opened. @author Sylvain Le Gall *) module Compat_0_4 = struct let rctxt = ref !BaseContext.default module BaseSetup = struct module Original = BaseSetup open OASISTypes type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } let setup t = let mk_std_args_fun f = fun ~ctxt pkg args -> rctxt := ctxt; f pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun ~ctxt pkg sct args -> rctxt := ctxt; f pkg sct args)) l in let t' = { Original. configure = mk_std_args_fun t.configure; build = mk_std_args_fun t.build; doc = mk_section_args_fun t.doc; test = mk_section_args_fun t.test; install = mk_std_args_fun t.install; uninstall = mk_std_args_fun t.uninstall; clean = List.map mk_std_args_fun t.clean; clean_doc = mk_section_args_fun t.clean_doc; clean_test = mk_section_args_fun t.clean_test; distclean = List.map mk_std_args_fun t.distclean; distclean_doc = mk_section_args_fun t.distclean_doc; distclean_test = mk_section_args_fun t.distclean_test; package = t.package; oasis_fn = t.oasis_fn; oasis_version = t.oasis_version; oasis_digest = t.oasis_digest; oasis_exec = t.oasis_exec; oasis_setup_args = t.oasis_setup_args; setup_update = t.setup_update; } in Original.setup t' end let adapt_setup_t setup_t = let module O = BaseSetup.Original in let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in let mk_section_args_fun l = List.map (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) l in { BaseSetup. configure = mk_std_args_fun setup_t.O.configure; build = mk_std_args_fun setup_t.O.build; doc = mk_section_args_fun setup_t.O.doc; test = mk_section_args_fun setup_t.O.test; install = mk_std_args_fun setup_t.O.install; uninstall = mk_std_args_fun setup_t.O.uninstall; clean = List.map mk_std_args_fun setup_t.O.clean; clean_doc = mk_section_args_fun setup_t.O.clean_doc; clean_test = mk_section_args_fun setup_t.O.clean_test; distclean = List.map mk_std_args_fun setup_t.O.distclean; distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; distclean_test = mk_section_args_fun setup_t.O.distclean_test; package = setup_t.O.package; oasis_fn = setup_t.O.oasis_fn; oasis_version = setup_t.O.oasis_version; oasis_digest = setup_t.O.oasis_digest; oasis_exec = setup_t.O.oasis_exec; oasis_setup_args = setup_t.O.oasis_setup_args; setup_update = setup_t.O.setup_update; } end module Compat_0_3 = struct include Compat_0_4 end end # 5662 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done and then output corresponding file. *) let configure ~ctxt:_ pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2; _}, {bs_build = build; _}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2; _}, {bs_build = build; _}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) (* TODO: rewrite this module with OASISFileSystem. *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" (* TODO: this can be more generic and used elsewhere. *) let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install = let in_destdir fn = try (* Practically speaking destdir is prepended at the beginning of the target filename *) (destdir ())^fn with PropList.Not_set _ -> fn in let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = let tgt_dir = if prepend_destdir then in_destdir (envdir ()) else envdir () in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register ~ctxt install_dir_ev dn) (Filename.dirname tgt_file); (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt src_file tgt_file; BaseLog.register ~ctxt install_file_ev tgt_file in (* Install the files for a library. *) let install_lib_files ~ctxt findlib_name files = let findlib_dir = let dn = let findlib_destdir = OASISExec.run_read_one_line ~ctxt (ocamlfind ()) ["printconf" ; "destdir"] in Filename.concat findlib_destdir findlib_name in fun () -> dn in let () = if not (OASISFileUtil.file_exists_case (findlib_dir ())) then failwithf (f_ "Directory '%s' doesn't exist for findlib library %s") (findlib_dir ()) findlib_name in let f dir file = let basename = Filename.basename file in let tgt_fn = Filename.concat dir basename in (* Destdir is already include in printconf. *) install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir in List.iter (fun (dir, files) -> List.iter (f dir) files) files ; in (* Install data into defined directory *) let install_data ~ctxt srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file ~ctxt fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (OASISString.capitalize_ascii modul ^ sufx) :: (OASISString.uncapitalize_ascii modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs ~ctxt pkg = let find_first_existing_files_in_path bs lst = let path = OASISHostPath.of_unix bs.bs_path in List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) lst) in let files_of_modules new_files typ cs bs modules = List.fold_left (fun acc modul -> begin try (* Add uncompiled header from the source tree *) [find_first_existing_files_in_path bs (make_fnames modul [".mli"; ".ml"])] with Not_found -> warning (f_ "Cannot find source header for module %s \ in %s %s") typ modul cs.cs_name; [] end @ List.fold_left (fun acc fn -> try find_first_existing_files_in_path bs [fn] :: acc with Not_found -> acc) acc (make_fnames modul [".annot";".cmti";".cmt"])) new_files modules in let files_of_build_section (f_data, new_files) typ cs bs = let extra_files = List.map (fun fn -> try find_first_existing_files_in_path bs [fn] with Not_found -> failwithf (f_ "Cannot find extra findlib file %S in %s %s ") fn typ cs.cs_name) bs.bs_findlib_extra_files in let f_data () = (* Install data associated with the library *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in f_data, new_files @ extra_files in let files_of_library (f_data, acc) data_lib = let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin (* Start with lib_extra *) let new_files = lib_extra in let new_files = files_of_modules new_files "library" cs bs lib.lib_modules in let f_data, new_files = files_of_build_section (f_data, new_files) "library" cs bs in let new_files = (* Get generated files *) BaseBuilt.fold ~ctxt BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) new_files in let acc = (dn, new_files) :: acc in let f_data () = (* Install data associated with the library *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin (* Start with obj_extra *) let new_files = obj_extra in let new_files = files_of_modules new_files "object" cs bs obj.obj_modules in let f_data, new_files = files_of_build_section (f_data, new_files) "object" cs bs in let new_files = (* Get generated files *) BaseBuilt.fold ~ctxt BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) new_files in let acc = (dn, new_files) :: acc in let f_data () = (* Install data associated with the object *) install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, dn, children) -> files_of_library data_and_files (cs, bs, lib, dn), children | Package (_, cs, bs, `Object obj, dn, children) -> files_of_object data_and_files (cs, bs, obj, dn), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) (* TODO: move to OASISHostPath as make_relative. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else begin n end in List.map (fun (dir, fn) -> (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) files in let ocamlfind = ocamlfind () in let nodir_files, dir_files = List.fold_left (fun (nodir, dir) (dn, lst) -> match dn with | Some dn -> nodir, (dn, lst) :: dir | None -> lst @ nodir, dir) ([], []) (List.rev files) in info (f_ "Installing findlib library '%s'") findlib_name; List.iter (OASISExec.run ~ctxt ocamlfind) (split_install_command ocamlfind findlib_name meta nodir_files); install_lib_files ~ctxt findlib_name dir_files; BaseLog.register ~ctxt install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs ~ctxt pkg = let install_exec data_exec = let cs, bs, _ = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold ~ctxt BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~ctxt ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold ~ctxt BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file ~ctxt fn exec_libdir) (); install_data ~ctxt bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs ~ctxt pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold ~ctxt BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) (); install_data ~ctxt Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in fun ~ctxt pkg _ -> install_libs ~ctxt pkg; install_execs ~ctxt pkg; install_docs ~ctxt pkg (* Uninstall already installed data *) let uninstall ~ctxt _ _ = let uninstall_aux (ev, data) = if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] end else begin failwithf (f_ "Unknown log event '%s'") ev; end; BaseLog.unregister ~ctxt ev data in (* We process event in reverse order *) List.iter uninstall_aux (List.rev (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); List.iter uninstall_aux (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) end # 6465 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; ] else []; if OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then [ "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (tests ()) then ["-tag"; "tests"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean ~ctxt extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild ~ctxt args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister ~ctxt e d) (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar let cond_targets_hook = ref (fun lst -> lst) let build ~ctxt extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cmo" fn || ends_with ~what:".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, _ when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register ~ctxt bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild ~ctxt (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean ~ctxt pkg extra_args = run_clean ~ctxt extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OCamlbuildCommon type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build ~ctxt run _ (cs, _) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv; List.iter (fun glb -> match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with | (_ :: _) as filenames -> BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] | [] -> ()) ["*.html"; "*.css"] let doc_clean ~ctxt _ _ (cs, _) argv = run_clean ~ctxt argv; BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name end # 6837 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build []; test = []; doc = []; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = []; clean_doc = []; distclean = []; distclean_test = []; distclean_doc = []; package = { oasis_version = "0.4"; ocaml_version = None; version = "0.0.03"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0" }); findlib_version = None; alpha_features = []; beta_features = []; name = "bamboo"; license_file = None; copyrights = []; maintainers = []; authors = ["Yoichi Hirai "]; homepage = Some "https://github.com/pirapira/bamboo"; bugreports = None; synopsis = "A compiler targeting Ethereum Virtual Machine"; description = Some [ OASISText.Para "Bamboo compiles a simple language to Ethereum Virtual Machine. The language is designed to keep programmers away from common mistakes. It features: state transition as recursion with potentially changing arguments, mandatory reentrance continuation when calling out, no loops, no assignments except to mappings and partial compliance with common Ethereum ABI." ]; tags = []; categories = []; files_ab = []; sections = [ SrcRepo ({ cs_name = "opam-pin"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { src_repo_type = Git; src_repo_location = "https://github.com/pirapira/bamboo.git"; src_repo_browser = None; src_repo_module = None; src_repo_branch = Some "master"; src_repo_tag = None; src_repo_subdir = None }); Library ({ cs_name = "cross-platform"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "src/cross-platform-for-ocamlbuild"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("batteries", None); FindlibPackage ("rope", None); FindlibPackage ("cryptokit", Some (OASISVersion.VGreaterEqual "1.12")); FindlibPackage ("hex", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "WrapBn"; "WrapCryptokit"; "WrapList"; "WrapString"; "WrapOption" ]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "basics"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "src/basics"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "cross-platform"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Assoc"; "Hexa"; "Label"; "Misc"; "Storage"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "ast"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "src/ast"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "basics"; FindlibPackage ("cryptokit", Some (OASISVersion.VGreaterEqual "1.12")); FindlibPackage ("hex", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "Contract"; "Syntax"; "TypeEnv"; "Type"; "PseudoImm"; "Evm"; "Location"; "Ethereum" ]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "parse"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "src/parse"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "ast"; FindlibPackage ("menhirLib", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Lexer"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Library ({ cs_name = "codegen"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "src/codegen"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "basics"; InternalLibrary "ast"; InternalLibrary "parse" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "CodegenEnv"; "Codegen"; "EntrypointDatabase"; "LayoutInfo"; "LocationEnv"; "Parse" ]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_directory = None; lib_findlib_containers = [] }); Executable ({ cs_name = "bamboo"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/exec"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "parse"; InternalLibrary "codegen"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_interface_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${capitalize_file module}.mli" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mli" ]; origin = "${uncapitalize_file module}.mli" } ]; bs_implementation_patterns = [ { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${capitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".ml" ]; origin = "${uncapitalize_file module}.ml" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${capitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mll" ]; origin = "${uncapitalize_file module}.mll" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("capitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${capitalize_file module}.mly" }; { OASISSourcePatterns.Templater.atoms = [ OASISSourcePatterns.Templater.Text ""; OASISSourcePatterns.Templater.Expr (OASISSourcePatterns.Templater.Call ("uncapitalize_file", OASISSourcePatterns.Templater.Ident "module")); OASISSourcePatterns.Templater.Text ".mly" ]; origin = "${uncapitalize_file module}.mly" } ]; bs_c_sources = []; bs_data_files = []; bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "bamboo.ml"}) ]; disable_oasis_section = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; plugins = [(`Extra, "META", Some "0.4")]; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.10"; oasis_digest = Some "\016\223\164\015\2320\133d\134\245\203K\139\234\205N"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7851 "setup.ml" let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t open BaseCompat.Compat_0_4 (* OASIS_STOP *) let () = setup ();; ================================================ FILE: sketch/future.bbo ================================================ contract A() { case (bool a()) { return (true) then become B(); } } contract B() { case (bool b()) { return (false) then become B(); } } contract C(A instance) { case (bool c()) { return (instance.b() reentrance { abort; }) then become C(instance); } } ================================================ FILE: sketch/open_auction.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { case (bool bid()) { if (now(block) > _bidding_time) return (false) then become auction_done(_beneficiary, _bids, _highest_bid); if (value(msg) < _highest_bid) abort; bid new_bid = deploy bid(sender(msg), value(msg), this) with value(msg) reentrance { abort; }; // failure throws. _bids[address(new_bid)] = true; return (true) then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } case (uint256 highest_bid()) { return (_highest_bid) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (uint256 bidding_time()) { return (_bidding_time) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } default { abort; // cancels the call. } // When the control reaches the end of a contract block, // it causes an abort. } contract bid (address _bidder ,uint256 _value ,auction _auction) // the compiler is aware that an `auction` account can become an `auction_done` account. { case (bool refund()) { if (sender(msg) != _bidder) abort; if (_auction.bid_is_highest(_value) reentrance { abort; }) abort; selfdestruct(_bidder); } case (bool pay_beneficiary()) { if (not _auction.bid_is_highest(_value) reentrance { abort; }) abort; address beneficiary = _auction.beneficiary() reentrance { abort; }; selfdestruct(beneficiary); } default { abort; } } contract auction_done(address _beneficiary, address => bool _bids, uint256 _highest_bid) { case (bool bid_is_highest(uint256 _cand)) { if (not _bids[sender(msg)]) abort; return (_highest_bid == _cand) then become auction_done(_beneficiary, _bids, _highest_bid); } case (address beneficiary()) { if (not _bids[sender(msg)]) abort; return (_beneficiary) then become auction_done(_beneficiary, _bids, _highest_bid); } default { abort; } } ================================================ FILE: src/ast/META ================================================ # OASIS_START # DO NOT EDIT (digest: 48b4bddcf78ccaf67607c0efb8f15589) version = "0.0.03" description = "A compiler targeting Ethereum Virtual Machine" requires = "basics cryptokit hex" archive(byte) = "ast.cma" archive(byte, plugin) = "ast.cma" archive(native) = "ast.cmxa" archive(native, plugin) = "ast.cmxs" exists_if = "ast.cma" # OASIS_STOP ================================================ FILE: src/ast/ast.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: 857e7a85bbf5c81d7dc95b28750b7723) Contract Syntax TypeEnv Type PseudoImm Evm Location Ethereum # OASIS_STOP ================================================ FILE: src/ast/ast.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: 857e7a85bbf5c81d7dc95b28750b7723) Contract Syntax TypeEnv Type PseudoImm Evm Location Ethereum # OASIS_STOP ================================================ FILE: src/ast/ast_test.ml ================================================ open Lexer open Lexing open Printf (* The following two functions comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) let print_position outx lexbuf = let pos = lexbuf.lex_curr_p in fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) let parse_with_error lexbuf = try Parser.file Lexer.read lexbuf with | SyntaxError msg -> fprintf stderr "%a: %s\n" print_position lexbuf msg; exit (-1) | Parser.Error -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) | _ -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) let _ = let lexbuf = Lexing.from_channel stdin in let contracts : unit Syntax.toplevel list = parse_with_error lexbuf in let contracts = Assoc.list_to_contract_id_assoc contracts in let _ = Type.assign_types contracts in Printf.printf "Finished typing.\n" ================================================ FILE: src/ast/contract.ml ================================================ type case_interface = Ethereum.function_signature let case_interface_of (raw : 'exp Syntax.case) : case_interface = match Syntax.(raw.case_header) with | Syntax.UsualCaseHeader header -> { Ethereum.sig_return = List.map Ethereum.interpret_interface_type Syntax.(header.case_return_typ) ; sig_name = Syntax.(header.case_name) ; sig_args = List.map Ethereum.interpret_interface_type Syntax.(List.map (fun x -> x.arg_typ) header.case_arguments) } | Syntax.DefaultCaseHeader -> { Ethereum.sig_return = [] ; sig_name = "" (* is this a good choice? *) ; sig_args = [] } type contract_interface = { contract_interface_name : string (** [contract_interface_name] is the name of the contract. *) ; contract_interface_args : Syntax.typ list (* Since [contract_interface_args] contains bool[address] and such, * is's not appropriate to use the ABI signature here. * As a work around, at the time of deployment, these * arrays are zeroed out. *) ; contract_interface_cases : case_interface list ; contract_interface_continuations : string list (** [contract_interface_transitions] lists the names of contracts that this one can continue into *) } let rec collect_continuation_in_sentence (raw : 'exp Syntax.sentence) : string list = Syntax.( match raw with | AbortSentence -> [] | ReturnSentence r -> begin match contract_name_of_return_cont r.return_cont with | None -> [] | Some name -> [name] end | AssignmentSentence (_, _) -> [] | VariableInitSentence _ -> [] | SelfdestructSentence _ -> [] | IfThenOnly (_, ss) -> collect_continuation_in_sentences ss | IfThenElse (_, s, t) -> (collect_continuation_in_sentences) s @ (collect_continuation_in_sentences t) | ExpSentence _ -> [] | LogSentence _ -> [] ) and collect_continuation_in_sentences ss = List.concat (List.map collect_continuation_in_sentence ss) let collect_continuation_in_case (raw : 'exp Syntax.case) : string list = List.concat Syntax.(List.map collect_continuation_in_sentence raw.case_body) let collect_continuation_in_contract (raw : 'exp Syntax.contract) : string list = List.concat Syntax.(List.map collect_continuation_in_case raw.contract_cases) let contract_interface_of (raw : 'exp Syntax.contract) : contract_interface = Syntax. { contract_interface_name = raw.contract_name ; contract_interface_args = List.map (fun x -> x.arg_typ) raw.contract_arguments ; contract_interface_cases = List.map case_interface_of raw.contract_cases ; contract_interface_continuations = collect_continuation_in_contract raw } let find_method_sig_in_contract (method_name : string) (i : contract_interface) : case_interface option = Misc.first_some (fun case_inter -> if case_inter.Ethereum.sig_name = method_name then Some case_inter else None ) i.contract_interface_cases let find_method_signature (interfaces : contract_interface Assoc.contract_id_assoc) (contract_name : string) (method_name : string) : case_interface option = Misc.first_some (find_method_sig_in_contract method_name) (List.map snd interfaces) ================================================ FILE: src/ast/contract.mli ================================================ type case_interface = Ethereum.function_signature val case_interface_of : 'exp Syntax.case -> case_interface type contract_interface = { contract_interface_name : string (** [contract_interface_name] is the name of the contract. *) ; contract_interface_args : Syntax.typ list ; contract_interface_cases : case_interface list ; contract_interface_continuations : string list (** [contract_interface_transitions] lists the names of contracts that this one can continue into *) } val contract_interface_of : 'exp Syntax.contract -> contract_interface val find_method_signature : contract_interface Assoc.contract_id_assoc -> string (* contract name *) -> string (* method name *) -> case_interface option ================================================ FILE: src/ast/ethereum.ml ================================================ let word_bits = 256 let signature_bits = 32 type interface_typ = | InterfaceUint of int | InterfaceBytes of int | InterfaceAddress | InterfaceBool type interface_arg = string * interface_typ (** [interpret_interface_type] parses "uint" into InterfaceUint 256, etc. *) let interpret_interface_type (str : Syntax.typ) : interface_typ = Syntax. (match str with | Uint256Type -> InterfaceUint 256 | Uint8Type -> InterfaceUint 8 | Bytes32Type -> InterfaceBytes 32 | AddressType -> InterfaceAddress | BoolType -> InterfaceBool | TupleType _ -> failwith "interpret_interface_type: tuple types are not supported yet" | MappingType (_, _) -> failwith "interpret_interface_type: mapping type not supported" | ContractInstanceType _ -> InterfaceAddress | ContractArchType _ -> failwith "contract arch-type does not appear in the ABI" | ReferenceType _ -> failwith "reference type does not appear in the ABI" | VoidType -> failwith "VoidType should not appear in the ABI" ) let to_typ (ityp : interface_typ) = Syntax. ( match ityp with | InterfaceUint x -> let () = if (x < 0 || x > 256) then failwith "too small or too big integer" in Uint256Type | InterfaceBytes x -> let () = assert (x = 32) in Bytes32Type | InterfaceBool -> BoolType | InterfaceAddress -> AddressType ) (* in bytes *) let interface_typ_size (ityp : interface_typ) : int = match ityp with | InterfaceUint _ -> 32 | InterfaceAddress -> 32 | InterfaceBool -> 32 | InterfaceBytes _ -> 32 type function_signature = { sig_return : interface_typ list ; sig_name : string ; sig_args : interface_typ list } let get_interface_typ (raw : Syntax.arg) : (string * interface_typ) option = match Syntax.(raw.arg_typ) with | Syntax.MappingType (_,_) -> None | _ -> Some (raw.Syntax.arg_ident, interpret_interface_type Syntax.(raw.arg_typ)) let get_interface_typs : Syntax.arg list -> (string * interface_typ) list = WrapList.filter_map get_interface_typ let rec argument_sizes_to_positions_inner ret used sizes = match sizes with | [] -> List.rev ret | h :: t -> let () = assert (h > 0) in let () = assert (h <= 32) in (* XXX using div and mod, generalization is possible *) argument_sizes_to_positions_inner (used + 32 - h :: ret) (used + 32) t let argument_sizes_to_positions sizes = argument_sizes_to_positions_inner [] 4 (* size of signature *) sizes let print_arg_loc r = List.iter (fun (name, loc) -> Printf.printf "argument %s at %s\n" name (Location.as_string loc) ) r let arguments_with_locations (c : Syntax.typ Syntax.case) : (string * Location.location) list = Syntax.( match c.case_header with | DefaultCaseHeader -> [] | UsualCaseHeader h -> let sizes : int list = List.map calldata_size_of_arg h.Syntax.case_arguments in let positions : int list = argument_sizes_to_positions sizes in let size_pos : (int * int) list = List.combine positions sizes in let locations : Location.location list = List.map (fun (o, s) -> Location.(Calldata {calldata_offset = o; calldata_size = s})) size_pos in let names : string list = List.map (fun a -> a.Syntax.arg_ident) h.Syntax.case_arguments in let ret = List.combine names locations in ret ) let get_array (raw : Syntax.arg) : (string * Syntax.typ * Syntax.typ) option = match Syntax.(raw.arg_typ) with | Syntax.MappingType (k, v) -> Some (raw.Syntax.arg_ident, k, v) | _ -> None let arrays_in_contract c : (string * Syntax.typ * Syntax.typ) list = WrapList.filter_map get_array (c.Syntax.contract_arguments) let constructor_arguments (contract : Syntax.typ Syntax.contract) : (string * interface_typ) list = get_interface_typs (contract.Syntax.contract_arguments) let total_size_of_interface_args lst : int = try WrapList.sum (List.map interface_typ_size lst) with Invalid_argument _ -> 0 let string_keccak = WrapCryptokit.string_keccak let hex_keccak = WrapCryptokit.hex_keccak (* Since `string_keccak` returns a hex representation of byte sequence, as we want the first four bytes, we need to take the first eight characters. *) let keccak_signature (str : string) : string = String.sub (string_keccak str) 0 8 let string_of_interface_type (i : interface_typ) : string = match i with | InterfaceUint x -> "uint"^(string_of_int x) | InterfaceBytes x -> "bytes"^(string_of_int x) | InterfaceAddress -> "address" | InterfaceBool -> "bool" let case_header_signature_string (h : Syntax.usual_case_header) : string = let name_of_case = h.Syntax.case_name in let arguments = get_interface_typs h.Syntax.case_arguments in let arg_typs = List.map snd arguments in let list_of_types = List.map string_of_interface_type arg_typs in let args = String.concat "," list_of_types in name_of_case ^ "(" ^ args ^ ")" (* XXX: refactor with the above function *) let event_signature_string (e : Syntax.event) : string = (* do I consider indexed no? *) let name = e.Syntax.event_name in let arguments = get_interface_typs (List.map Syntax.arg_of_event_arg e.Syntax.event_arguments) in let arg_typs = List.map snd arguments in let list_of_types = List.map string_of_interface_type arg_typs in let args = String.concat "," list_of_types in name ^ "(" ^ args ^ ")" let case_header_signature_hash (h : Syntax.usual_case_header) : string = let sign = case_header_signature_string h in keccak_signature sign let event_signature_hash (e : Syntax.event) : string = let sign = event_signature_string e in keccak_signature sign let compute_signature_hash (signature : string) : string = String.sub (string_keccak signature) 0 8 let print_default_header = "{\"type\":\"fallback\",\"inputs\": [],\"outputs\": [],\"payable\": true}" let print_input_abi (arg : Syntax.arg) : string = Printf.sprintf "{\"name\": \"%s\", \"type\": \"%s\"}" (arg.Syntax.arg_ident) (string_of_interface_type (interpret_interface_type arg.Syntax.arg_typ)) let print_inputs_abi (args : Syntax.arg list) : string = let strings = List.map print_input_abi args in String.concat "," strings let print_output_abi (typ : Syntax.typ) : string = Printf.sprintf "{\"name\": \"\", \"type\": \"%s\"}" (string_of_interface_type (interpret_interface_type typ)) let print_outputs_abi (typs : Syntax.typ list) : string = let strings = List.map print_output_abi typs in String.concat "," strings let print_usual_case_abi u = Printf.sprintf "{\"type\":\"function\",\"name\":\"%s\",\"inputs\": [%s],\"outputs\": [%s],\"payable\": true}" (u.Syntax.case_name) (print_inputs_abi u.Syntax.case_arguments) (print_outputs_abi u.Syntax.case_return_typ) let print_case_abi (c : Syntax.typ Syntax.case) : string = match c.Syntax.case_header with | Syntax.UsualCaseHeader u -> print_usual_case_abi u | Syntax.DefaultCaseHeader -> print_default_header let print_constructor_abi (c : Syntax.typ Syntax.contract) : string = Printf.sprintf "{\"type\": \"constructor\", \"inputs\":[%s], \"name\": \"%s\", \"outputs\":[], \"payable\": true}" (print_inputs_abi (List.filter Syntax.non_mapping_arg c.Syntax.contract_arguments)) (c.Syntax.contract_name) let print_contract_abi seen_constructor (c : Syntax.typ Syntax.contract) : string = let cases = c.Syntax.contract_cases in let strings : string list = List.map print_case_abi cases in let strings = if !seen_constructor then strings else (print_constructor_abi c) :: strings in let () = (seen_constructor := true) in String.concat "," strings let print_event_arg (a : Syntax.event_arg) : string = Printf.sprintf "{\"name\":\"%s\",\"type\":\"%s\",\"indexed\":%s}" Syntax.(a.event_arg_body.arg_ident) (string_of_interface_type (interpret_interface_type Syntax.(a.event_arg_body.arg_typ))) (string_of_bool a.Syntax.event_arg_indexed) let print_event_inputs (is : Syntax.event_arg list) : string = let strings : string list = List.map print_event_arg is in String.concat "," strings let print_event_abi (e : Syntax.event) : string = Printf.sprintf "{\"type\":\"event\",\"inputs\":[%s],\"name\":\"%s\"}" (print_event_inputs e.Syntax.event_arguments) (e.Syntax.event_name) let print_toplevel_abi seen_constructor (t : Syntax.typ Syntax.toplevel) : string = match t with | Syntax.Contract c -> print_contract_abi seen_constructor c | Syntax.Event e -> print_event_abi e let print_abi (tops : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc) : unit = let seen_constructor = ref false in let () = Printf.printf "[" in let strings : string list = List.filter (fun s -> (String.length s) != 0) (List.map (print_toplevel_abi seen_constructor) (Assoc.values tops)) in let () = Printf.printf "%s" (String.concat "," strings) in Printf.printf "]" ================================================ FILE: src/ast/ethereum.mli ================================================ val word_bits : int val signature_bits : int type interface_typ = | InterfaceUint of int | InterfaceBytes of int | InterfaceAddress | InterfaceBool (** size of values of the interface type in bytes *) val interface_typ_size : interface_typ -> int type interface_arg = string * interface_typ (** [interpret_interface_type] parses "uint" into InterfaceUint 256, etc. *) val interpret_interface_type : Syntax.typ -> interface_typ val to_typ : interface_typ -> Syntax.typ (** [string_of_interface_type t] is a string that is used to compute the * method signatures. Addresses are "address", uint is "uint256". *) val string_of_interface_type : interface_typ -> string type function_signature = { sig_return : interface_typ list ; sig_name : string ; sig_args : interface_typ list } val get_interface_typs : Syntax.arg list -> (string * interface_typ) list val arguments_with_locations : Syntax.typ Syntax.case -> (string * Location.location) list val constructor_arguments : Syntax.typ Syntax.contract -> (string * interface_typ) list val arrays_in_contract : Syntax.typ Syntax.contract -> (string * Syntax.typ * Syntax.typ) list val total_size_of_interface_args : interface_typ list -> int (** [string_keccak] returns the Keccak-256 hash of a string in * hex, without the prefix [0x]. *) val string_keccak : string -> string (** [hex_keccak] expects a hex string and returns the Keccak-256 hash of the * represented byte sequence, without the prefix [0x]. *) val hex_keccak : string -> string (** [keccak_short "pay(address)"] returns the * method signature code (which is commonly used in the ABI. *) val keccak_signature : string -> string (** [case_heaer_signature_string h] returns the * signature of a fucntion as used for creating the * function hash. Like "pay(address)" * TODO: cite some document here. *) val case_header_signature_string : Syntax.usual_case_header -> string (** [compute_singature_hash] takes a string like `f(uint8,address)` and returns a 4byte signature hash commonly used in Ethereum ABI. *) val compute_signature_hash : string -> string (** [case_header_signature_hash h] returns the * method signature used in the common ABI. * The hex hash comes without 0x *) val case_header_signature_hash : Syntax.usual_case_header -> string val event_signature_hash : Syntax.event -> string val print_abi : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc -> unit ================================================ FILE: src/ast/evm.ml ================================================ type 'imm instruction = | PUSH1 of 'imm | PUSH4 of 'imm | PUSH32 of 'imm | NOT | TIMESTAMP | EQ | ISZERO | LT | GT | BALANCE | STOP | ADD | MUL | SUB | DIV | SDIV | MOD | SMOD | ADDMOD | MULMOD | EXP | SIGNEXTEND | SHA3 | ADDRESS | ORIGIN | CALLER | CALLVALUE | CALLDATALOAD | CALLDATASIZE | CALLDATACOPY | CODESIZE | CODECOPY | GASPRICE | EXTCODESIZE | EXTCODECOPY | POP | MLOAD | MSTORE | MSTORE8 | SLOAD | SSTORE | JUMP | JUMPI | PC | MSIZE | GAS | JUMPDEST of Label.label | LOG0 | LOG1 | LOG2 | LOG3 | LOG4 | CREATE | CALL | CALLCODE | RETURN | DELEGATECALL | SUICIDE | SWAP1 | SWAP2 | SWAP3 | SWAP4 | SWAP5 | SWAP6 | DUP1 | DUP2 | DUP3 | DUP4 | DUP5 | DUP6 | DUP7 type 'imm program = 'imm instruction list let num_instructions = List.length let empty_program = [] (** The program is stored in the reverse order *) let append_inst orig i = i :: orig let to_list (p : 'imm program) = List.rev p let stack_eaten = function | PUSH1 _ -> 0 | PUSH4 _ -> 0 | PUSH32 _ -> 0 | NOT -> 1 | TIMESTAMP -> 0 | EQ -> 2 | ISZERO -> 1 | LT -> 2 | GT -> 2 | BALANCE -> 1 | STOP -> 0 | ADD -> 2 | MUL -> 2 | SUB -> 2 | DIV -> 2 | SDIV -> 2 | MOD -> 2 | SMOD -> 2 | ADDMOD -> 3 | MULMOD -> 3 | EXP -> 2 | SIGNEXTEND -> 2 | SHA3 -> 2 | ADDRESS -> 0 | ORIGIN -> 0 | CALLER -> 0 | CALLVALUE -> 0 | CALLDATALOAD -> 1 | CALLDATASIZE -> 0 | CALLDATACOPY -> 3 | CODESIZE -> 0 | CODECOPY -> 3 | GASPRICE -> 0 | EXTCODESIZE -> 1 | EXTCODECOPY -> 4 | POP -> 1 | MLOAD -> 1 | MSTORE -> 2 | MSTORE8 -> 2 | SLOAD -> 1 | SSTORE -> 2 | JUMP -> 1 | JUMPI -> 2 | PC -> 0 | MSIZE -> 0 | GAS -> 0 | JUMPDEST _ -> 0 | SWAP1 -> 2 | SWAP2 -> 3 | SWAP3 -> 4 | SWAP4 -> 5 | SWAP5 -> 6 | SWAP6 -> 7 | LOG0 -> 2 | LOG1 -> 3 | LOG2 -> 4 | LOG3 -> 5 | LOG4 -> 6 | CREATE -> 3 | CALL -> 7 | CALLCODE -> 7 | RETURN -> 2 | DELEGATECALL -> 7 | SUICIDE -> 1 | DUP1 -> 1 | DUP2 -> 2 | DUP3 -> 3 | DUP4 -> 4 | DUP5 -> 5 | DUP6 -> 6 | DUP7 -> 7 let stack_pushed = function | PUSH1 _ -> 1 | PUSH4 _ -> 1 | PUSH32 _ -> 1 | NOT -> 1 | TIMESTAMP -> 1 | EQ -> 1 | ISZERO -> 1 | LT -> 1 | GT -> 1 | BALANCE -> 1 | STOP -> 0 | ADD -> 1 | MUL -> 1 | SUB -> 1 | DIV -> 1 | SDIV -> 1 | EXP -> 1 | MOD -> 1 | SMOD -> 1 | ADDMOD -> 1 | MULMOD -> 1 | SIGNEXTEND -> 1 | SHA3 -> 1 | ADDRESS -> 1 | ORIGIN -> 1 | CALLER -> 1 | CALLVALUE -> 1 | CALLDATALOAD -> 1 | CALLDATASIZE -> 1 | CALLDATACOPY -> 0 | CODESIZE -> 1 | CODECOPY -> 0 | GASPRICE -> 1 | EXTCODESIZE -> 1 | EXTCODECOPY -> 0 | POP -> 0 | MLOAD -> 1 | MSTORE -> 0 | MSTORE8 -> 0 | SLOAD -> 1 | SSTORE -> 0 | JUMP -> 0 | JUMPI -> 0 | PC -> 1 | MSIZE -> 1 | GAS -> 1 | JUMPDEST _ -> 0 | SWAP1 -> 2 | SWAP2 -> 3 | SWAP3 -> 4 | SWAP4 -> 5 | SWAP5 -> 6 | SWAP6 -> 7 | DUP1 -> 2 | DUP2 -> 3 | DUP3 -> 4 | DUP4 -> 5 | DUP5 -> 6 | DUP6 -> 7 | DUP7 -> 8 | LOG0 -> 0 | LOG1 -> 0 | LOG2 -> 0 | LOG3 -> 0 | LOG4 -> 0 | CREATE -> 1 | CALL -> 1 | CALLCODE -> 1 | RETURN -> 0 | DELEGATECALL -> 1 | SUICIDE -> 0 let string_of_pseudo_opcode op = match op with | PUSH1 v -> "PUSH1 "^(PseudoImm.string_of_pseudo_imm v) | PUSH4 v -> "PUSH4 "^(PseudoImm.string_of_pseudo_imm v) | PUSH32 v -> "PUSH32 "^(PseudoImm.string_of_pseudo_imm v) | NOT -> "NOT" | TIMESTAMP -> "TIMESTAMP" | EQ -> "EQ" | ISZERO -> "ISZERO" | LT -> "LT" | GT -> "GT" | BALANCE -> "BALANCE" | STOP -> "STOP" | ADD -> "ADD" | MUL -> "MUL" | SUB -> "SUB" | DIV -> "DIV" | SDIV -> "SDIV" | EXP -> "EXP" | MOD -> "MOD" | SMOD -> "SMOD" | ADDMOD -> "ADDMOD" | MULMOD -> "MULMOD" | SIGNEXTEND -> "SIGNEXTEND" | SHA3 -> "SHA3" | ADDRESS -> "ADDRESS" | ORIGIN -> "ORIGIN" | CALLER -> "CALLER" | CALLVALUE -> "CALLVALUE" | CALLDATALOAD -> "CALLDATALOAD" | CALLDATASIZE -> "CALLDATASIZE" | CALLDATACOPY -> "CALLDATACOPY" | CODESIZE -> "CODESIZE" | CODECOPY -> "CODECOPY" | GASPRICE -> "GASPRICE" | EXTCODESIZE -> "EXTCODESIZE" | EXTCODECOPY -> "EXTCODECOPY" | POP -> "POP" | MLOAD -> "MLOAD" | MSTORE -> "MSTORE" | MSTORE8 -> "MSTORE8" | SLOAD -> "SLOAD" | SSTORE -> "SSTORE" | JUMP -> "JUMP" | JUMPI -> "JUMPI" | PC -> "PC" | MSIZE -> "MSIZE" | GAS -> "GAS" | JUMPDEST l -> "JUMPDEST (print label)" | SWAP1 -> "SWAP1" | SWAP2 -> "SWAP2" | SWAP3 -> "SWAP3" | SWAP4 -> "SWAP5" | SWAP5 -> "SWAP5" | SWAP6 -> "SWAP6" | DUP1 -> "DUP1" | DUP2 -> "DUP2" | DUP3 -> "DUP3" | DUP4 -> "DUP4" | DUP5 -> "DUP5" | DUP6 -> "DUP6" | DUP7 -> "DUP7" | LOG0 -> "LOG0" | LOG1 -> "LOG1" | LOG2 -> "LOG2" | LOG3 -> "LOG3" | LOG4 -> "LOG4" | CREATE -> "CREATE" | CALL -> "CALL" | CALLCODE -> "CALLCODE" | RETURN -> "RETURN" | DELEGATECALL -> "DELEGATECALL" | SUICIDE -> "SUICIDE" let string_of_pseudo_program prg = let op_lst = to_list prg in String.concat "" (List.map (fun op -> string_of_pseudo_opcode op ^ "\n") op_lst) let print_pseudo_program prg = Printf.printf "%s" (string_of_pseudo_program prg) let hex_of_instruction (i : WrapBn.t instruction) : Hexa.hex = let h = Hexa.hex_of_string in match i with | PUSH1 i -> Hexa.concat_hex (h "60") (Hexa.hex_of_big_int i 1) | PUSH4 i -> Hexa.concat_hex (h "63") (Hexa.hex_of_big_int i 4) | PUSH32 i -> Hexa.concat_hex (h "7f") (Hexa.hex_of_big_int i 32) | NOT -> h "19" | TIMESTAMP -> h "42" | EQ -> h "14" | ISZERO -> h "15" | LT -> h "10" | GT -> h "11" | BALANCE -> h "31" | STOP -> h "00" | ADD -> h "01" | MUL -> h "02" | SUB -> h "03" | DIV -> h "04" | SDIV -> h "05" | MOD -> h "06" | SMOD -> h "07" | ADDMOD -> h "08" | MULMOD -> h "09" | EXP -> h "0a" | SIGNEXTEND -> h "0b" | SHA3 -> h "20" | ADDRESS -> h "30" | ORIGIN -> h "32" | CALLER -> h "33" | CALLVALUE -> h "34" | CALLDATALOAD -> h "35" | CALLDATASIZE -> h "36" | CALLDATACOPY -> h "37" | CODESIZE -> h "38" | CODECOPY -> h "39" | GASPRICE -> h "3a" | EXTCODESIZE -> h "3b" | EXTCODECOPY -> h "3c" | POP -> h "50" | MLOAD -> h "51" | MSTORE -> h "52" | MSTORE8 -> h "53" | SLOAD -> h "54" | SSTORE -> h "55" | JUMP -> h "56" | JUMPI -> h "57" | PC -> h "58" | MSIZE -> h "59" | GAS -> h "5a" | JUMPDEST _ -> h "5b" | LOG0 -> h "a0" | LOG1 -> h "a1" | LOG2 -> h "a2" | LOG3 -> h "a3" | LOG4 -> h "a4" | CREATE -> h "f0" | CALL -> h "f1" | CALLCODE -> h "f2" | RETURN -> h "f3" | DELEGATECALL -> h "f4" | SUICIDE -> h "ff" | SWAP1 -> h "90" | SWAP2 -> h "91" | SWAP3 -> h "92" | SWAP4 -> h "93" | SWAP5 -> h "94" | SWAP6 -> h "95" | DUP1 -> h "80" | DUP2 -> h "81" | DUP3 -> h "82" | DUP4 -> h "83" | DUP5 -> h "84" | DUP6 -> h "85" | DUP7 -> h "86" let log (n : int) = match n with | 0 -> LOG0 | 1 -> LOG1 | 2 -> LOG2 | 3 -> LOG3 | 4 -> LOG4 | _ -> failwith "too many indexed arguments for an event" let rev_append_op (h : Hexa.hex) (i : WrapBn.t instruction) : Hexa.hex = Hexa.concat_hex (hex_of_instruction i) h let hex_of_program (p : WrapBn.t program) : Hexa.hex = List.fold_left rev_append_op Hexa.empty_hex p let print_imm_program (p : WrapBn.t program) : unit = let hex = hex_of_program p in Hexa.print_hex ~prefix:"0x" hex let string_of_imm_program (p : WrapBn.t program) : string = let hex = hex_of_program p in Hexa.string_of_hex ~prefix:"0x" hex let size_of_instruction i = match i with | PUSH1 _ -> 2 | PUSH4 _ -> 5 | PUSH32 _ -> 33 | _ -> 1 let size_of_program p = List.fold_left (fun a i -> a + size_of_instruction i) 0 p let dup_suc_n (n : int) = match n with | 0 -> DUP1 | 1 -> DUP2 | 2 -> DUP3 | 3 -> DUP4 | 4 -> DUP5 | 5 -> DUP6 | 6 -> DUP7 | _ -> failwith "more DUP instructions needed" ================================================ FILE: src/ast/evm.mli ================================================ type 'imm instruction = | PUSH1 of 'imm | PUSH4 of 'imm | PUSH32 of 'imm | NOT | TIMESTAMP | EQ | ISZERO | LT | GT | BALANCE | STOP | ADD | MUL | SUB | DIV | SDIV | MOD | SMOD | ADDMOD | MULMOD | EXP | SIGNEXTEND | SHA3 | ADDRESS | ORIGIN | CALLER | CALLVALUE | CALLDATALOAD | CALLDATASIZE | CALLDATACOPY | CODESIZE | CODECOPY | GASPRICE | EXTCODESIZE | EXTCODECOPY | POP | MLOAD | MSTORE | MSTORE8 | SLOAD | SSTORE | JUMP | JUMPI | PC | MSIZE | GAS | JUMPDEST of Label.label | LOG0 | LOG1 | LOG2 | LOG3 | LOG4 | CREATE | CALL | CALLCODE | RETURN | DELEGATECALL | SUICIDE | SWAP1 | SWAP2 | SWAP3 | SWAP4 | SWAP5 | SWAP6 | DUP1 | DUP2 | DUP3 | DUP4 | DUP5 | DUP6 | DUP7 val log : int -> 'a instruction val dup_suc_n : int -> 'imm instruction (** ['imm program] is a sequence of EVM instructions * where immediate values are expressed with type 'imm *) type 'imm program = 'imm instruction list val empty_program : 'imm program val num_instructions : 'imm program -> int val append_inst : 'imm program -> 'imm instruction -> 'imm program val stack_eaten : 'imm instruction -> int val stack_pushed : 'imm instruction -> int val string_of_pseudo_opcode : PseudoImm.pseudo_imm instruction -> string val string_of_pseudo_program : PseudoImm.pseudo_imm program -> string val print_pseudo_program : PseudoImm.pseudo_imm program -> unit val hex_of_instruction : WrapBn.t instruction -> Hexa.hex val hex_of_program : WrapBn.t program -> Hexa.hex val string_of_imm_program : WrapBn.t program -> string val print_imm_program : WrapBn.t program -> unit val size_of_instruction : 'exp instruction -> int val size_of_program : 'exp program -> int (* Commented out till we need it. val string_of_real_instruction : WrapBn.t instruction -> string val string_of_real_program : WrapBn.t program -> unit *) ================================================ FILE: src/ast/location.ml ================================================ type 'imm memory_range = { memory_start : 'imm (* In byte as in EVM *) ; memory_size : 'imm (* In byte *) } type 'imm storage_range = { storage_start : 'imm (* In word as in EVM *) ; storage_size : 'imm (* In word *) } type 'imm code_range = { code_start : 'imm (* In byte *) ; code_size : 'imm } type 'imm volatile_location = | Memory of 'imm memory_range | Stack of int (** [Stack 0] is the deepest element in the stack. * The stack usage should be known from the beginning of the * code generation. *) type 'imm cached_storage = { cached_original: 'imm storage_range ; modified : bool (* if the cache has to be written again *) ; cache : 'imm volatile_location } type calldata_range = { calldata_offset : int ; calldata_size : int } type location = | Storage of PseudoImm.pseudo_imm storage_range | CachedStorage of PseudoImm.pseudo_imm cached_storage | Volatile of PseudoImm.pseudo_imm volatile_location | Code of PseudoImm.pseudo_imm code_range | Calldata of calldata_range | Stack of int let as_string (l : location) : string = match l with | Storage _ -> "Storage ..." | CachedStorage _ -> "CachedStorage ..." | Volatile _ -> "Volatile ..." | Code _ -> "Code ..." | Calldata c -> Printf.sprintf "Calldata offset %d, size %d" c.calldata_offset c.calldata_size | Stack i -> Printf.sprintf "Stack %d" i ================================================ FILE: src/ast/location.mli ================================================ (* This module annotates idents with the locations of the data *) type 'imm memory_range = { memory_start : 'imm (* In byte as in EVM *) ; memory_size : 'imm (* In byte *) } type 'imm storage_range = { storage_start : 'imm (* In word as in EVM *) ; storage_size : 'imm (* In word *) } type 'imm code_range = { code_start : 'imm (* In byte *) ; code_size : 'imm } type 'imm volatile_location = | Memory of 'imm memory_range | Stack of int (** [Stack 0] is the deepest element in the stack. * The stack usage should be known from the beginning of the * code generation. *) type 'imm cached_storage = { cached_original: 'imm storage_range ; modified : bool (* if the cache has to be written again *) ; cache : 'imm volatile_location } type calldata_range = { calldata_offset : int ; calldata_size : int } type location = | Storage of PseudoImm.pseudo_imm storage_range | CachedStorage of PseudoImm.pseudo_imm cached_storage | Volatile of PseudoImm.pseudo_imm volatile_location | Code of PseudoImm.pseudo_imm code_range | Calldata of calldata_range | Stack of int val as_string : location -> string ================================================ FILE: src/ast/pseudoImm.ml ================================================ (* pseudo immediate value *) type pseudo_imm = | Big of WrapBn.t | Int of int | DestLabel of Label.label | StorageProgramCounterIndex | StorageConstructorArgumentsBegin of Assoc.contract_id | StorageConstructorArgumentsSize of Assoc.contract_id (* the size is dependent on the contract id *) | InitDataSize of Assoc.contract_id | ContractOffsetInRuntimeCode of Assoc.contract_id (* where in the runtime code does the contract start. This index should be a JUMPDEST *) | CaseOffsetInRuntimeCode of Assoc.contract_id * Syntax.case_header | ConstructorCodeSize of Assoc.contract_id | ConstructorInRuntimeCodeOffset of Assoc.contract_id | RuntimeCodeOffset of Assoc.contract_id | RuntimeCodeSize | Minus of pseudo_imm * pseudo_imm let rec string_of_pseudo_imm (p : pseudo_imm) : string = match p with | Big b -> "(Big "^(WrapBn.string_of_big_int b)^")" | Int i -> "(Int "^(string_of_int i)^")" | DestLabel _ -> "DestLabel (print label here)" | StorageProgramCounterIndex -> "StorageProgramCounterIndex" | StorageConstructorArgumentsBegin _ -> "StorageConstructorArgumentBegin (print contract id)" | StorageConstructorArgumentsSize _ -> "StorageConstructorArgumentsSize (print contract id)" | InitDataSize cid -> "InitDataSize (print contract id here)" | ContractOffsetInRuntimeCode _ -> "ContractOffsetInRuntimeCode (print contact id)" | CaseOffsetInRuntimeCode (cid, header) -> "CaseOffsetInRuntimeCode (print contract id, case header)" | ConstructorCodeSize cid -> "ConstructorCodeSize (print contract id)" | ConstructorInRuntimeCodeOffset cid -> "ConstructorInRuntimeCodeOffset (print contract id)" | RuntimeCodeOffset cid -> "RuntimeCodeOffset (print contract id)" | RuntimeCodeSize -> "RuntimeCodeSize" | Minus (a, b) -> "(- "^(string_of_pseudo_imm a)^" "^(string_of_pseudo_imm b)^")" let is_constant_big (b : WrapBn.t) (p : pseudo_imm) : bool = match p with | Big b' -> WrapBn.eq_big_int b b' | Int i -> WrapBn.(eq_big_int (big_int_of_int i) b) | _ -> false (* XXX: very rough approximation *) let is_constant_int (i : int) = is_constant_big (WrapBn.big_int_of_int i) ================================================ FILE: src/ast/pseudoImm.mli ================================================ (* pseudo immediate value *) type pseudo_imm = | Big of WrapBn.t | Int of int | DestLabel of Label.label | StorageProgramCounterIndex | StorageConstructorArgumentsBegin of Assoc.contract_id | StorageConstructorArgumentsSize of Assoc.contract_id | InitDataSize of Assoc.contract_id (** [InitDataSize cid] represents the size of the data sent to create the transaction. * This data contains the initializing code plus runtime code plus the constructor * argument data. Since the constructor arguments differ from a contract to a contract, * [InitDataSize] requires a contract id. *) | ContractOffsetInRuntimeCode of Assoc.contract_id (* where in the runtime code does the contract start. This index should be a JUMPDEST *) | CaseOffsetInRuntimeCode of Assoc.contract_id * Syntax.case_header (* constructor code is the part of the init code before the runtime code as payload. *) | ConstructorCodeSize of Assoc.contract_id (* for runtime code creation, the runtime code also contains the constructor code. *) | ConstructorInRuntimeCodeOffset of Assoc.contract_id | RuntimeCodeOffset of Assoc.contract_id | RuntimeCodeSize | Minus of pseudo_imm * pseudo_imm val string_of_pseudo_imm : pseudo_imm -> string val is_constant_big : WrapBn.t -> pseudo_imm -> bool val is_constant_int : int -> pseudo_imm -> bool ================================================ FILE: src/ast/sideEffect.ml ================================================ type location = Storage | External | Balance type kind = Read | Write type t = location * kind ================================================ FILE: src/ast/sideEffect.mli ================================================ type location = Storage | External | Balance type kind = Read | Write type t = location * kind ================================================ FILE: src/ast/syntax.ml ================================================ type typ = | VoidType | Uint256Type | Uint8Type | Bytes32Type | AddressType | BoolType | ReferenceType of typ list (** pointer to [typ list] on memory *) | TupleType of typ list | MappingType of typ * typ | ContractArchType of string (* type of [bid(...)] where bid is a contract *) | ContractInstanceType of string (* type of [b] declared as [bid b] *) let rec string_of_typ t = match t with | VoidType -> "void" | Uint256Type -> "uint256" | Uint8Type -> "uint8" | Bytes32Type -> "bytes32" | AddressType -> "address" | BoolType -> "bool" | MappingType (a, b) -> "mapping ("^string_of_typ a^" => "^string_of_typ b^")" | ContractArchType s -> "ContractArchType "^s | ContractInstanceType s -> "ContractInstanceType "^s | ReferenceType _ -> "pointer to ..." | TupleType _ -> "tuple" type arg = { arg_typ : typ ; arg_ident : string ; arg_location : SideEffect.location option } type event_arg = { event_arg_body : arg ; event_arg_indexed : bool } type event = { event_name : string ; event_arguments : event_arg list } type 'exp_annot function_call = { call_head : string ; call_args : ('exp_annot exp) list } and 'exp_annot message_info = { message_value_info : 'exp_annot exp option ; message_reentrance_info : 'exp_annot sentence list } and 'exp_annot new_exp = { new_head : string ; new_args : 'exp_annot exp list ; new_msg_info : 'exp_annot message_info } and 'exp_annot send_exp = { send_head_contract : 'exp_annot exp ; send_head_method : string option ; send_args : 'exp_annot exp list ; send_msg_info : 'exp_annot message_info } and 'exp_annot exp = 'exp_annot exp_inner * 'exp_annot and 'exp_annot exp_inner = | TrueExp | FalseExp | DecLit256Exp of WrapBn.t | DecLit8Exp of WrapBn.t | NowExp | FunctionCallExp of 'exp_annot function_call | IdentifierExp of string | ParenthExp of 'exp_annot exp | NewExp of 'exp_annot new_exp | SendExp of 'exp_annot send_exp | LandExp of 'exp_annot exp * 'exp_annot exp | LtExp of 'exp_annot exp * 'exp_annot exp | GtExp of 'exp_annot exp * 'exp_annot exp | NeqExp of 'exp_annot exp * 'exp_annot exp | EqualityExp of 'exp_annot exp * 'exp_annot exp | AddressExp of 'exp_annot exp | NotExp of 'exp_annot exp | ArrayAccessExp of 'exp_annot lexp | ValueExp | SenderExp | ThisExp | SingleDereferenceExp of 'exp_annot exp | TupleDereferenceExp of 'exp_annot exp | PlusExp of 'exp_annot exp * 'exp_annot exp | MinusExp of 'exp_annot exp * 'exp_annot exp | MultExp of 'exp_annot exp * 'exp_annot exp | BalanceExp of 'exp_annot exp and 'exp_annot lexp = | ArrayAccessLExp of 'exp_annot array_access and 'exp_annot array_access = { array_access_array : 'exp_annot exp ; array_access_index : 'exp_annot exp } and 'exp_annot variable_init = { variable_init_type : typ ; variable_init_name : string ; variable_init_value : 'exp_annot exp } and 'exp_annot sentence = | AbortSentence | ReturnSentence of 'exp_annot return | AssignmentSentence of 'exp_annot lexp * 'exp_annot exp | VariableInitSentence of 'exp_annot variable_init | IfThenOnly of 'exp_annot exp * 'exp_annot sentence list | IfThenElse of 'exp_annot exp * 'exp_annot sentence list * 'exp_annot sentence list | SelfdestructSentence of 'exp_annot exp | ExpSentence of 'exp_annot exp | LogSentence of string * 'exp_annot exp list * event option and 'exp_annot return = { return_exp : 'exp_annot exp option ; return_cont : 'exp_annot exp } let read_array_access (l : 'a lexp) = match l with | ArrayAccessLExp a -> a let event_arg_of_arg (a : arg) (indexed : bool) : event_arg = { event_arg_body = a ; event_arg_indexed = indexed } let arg_of_event_arg e = e.event_arg_body let split_event_args (e : event) (args : 'a exp list) = let indexed : bool list = List.map (fun (a : event_arg) -> a.event_arg_indexed) e.event_arguments in let combined : ('a exp * bool) list = List.combine args indexed in let (is, ns) = List.partition snd combined in (List.map fst is, List.map fst ns) type 'exp_annot case_body = 'exp_annot sentence list type usual_case_header = { case_return_typ : typ list ; case_name : string ; case_arguments : arg list } type case_header = | UsualCaseHeader of usual_case_header | DefaultCaseHeader type 'exp_annot case = { case_header : case_header ; case_body : 'exp_annot case_body } type 'exp_annot contract = { contract_name : string ; contract_arguments : arg list ; contract_cases : 'exp_annot case list } type 'exp_annot toplevel = | Contract of 'exp_annot contract | Event of event let contract_name_of_return_cont ((r, _) : 'exp exp) : string option = match r with | FunctionCallExp c -> Some c.call_head | _ -> None let case_header_arg_list (c : case_header) : arg list = match c with | UsualCaseHeader uch -> uch.case_arguments | DefaultCaseHeader -> [] let contract_name_of_instance ((_, (t, _)) : (typ * 'a) exp) = match t with | ContractInstanceType s -> s | typ -> failwith ("seeking contract_name_of non-contract "^(string_of_typ typ)) let string_of_exp_inner e = match e with | ThisExp -> "this" | ArrayAccessExp _ -> "a[idx]" | SendExp _ -> "send" | NewExp _ -> "new" | ParenthExp _ -> "()" | IdentifierExp str -> "ident "^str | FunctionCallExp _ -> "call" | NowExp -> "now" | SenderExp -> "sender" | TrueExp -> "true" | FalseExp -> "false" | DecLit256Exp d -> "declit "^(WrapBn.string_of_big_int d) | DecLit8Exp d -> "declit "^(WrapBn.string_of_big_int d) | NotExp _ -> "not" | NeqExp _ -> "neq" | LandExp _ -> "_ && _" | LtExp _ -> "lt" | GtExp _ -> "gt" | ValueExp -> "value" | EqualityExp _ -> "equality" | AddressExp _ -> "address" | SingleDereferenceExp _ -> "dereference of ..." | TupleDereferenceExp _ -> "dereference of tuple..." | PlusExp (a, b) -> "... + ..." | MinusExp (a, b) -> "... - ..." | MultExp (a, b) -> "... * ..." | BalanceExp _ -> "balance" let is_mapping (typ : typ) = match typ with | Uint256Type | Uint8Type | Bytes32Type | AddressType | BoolType | ReferenceType _ | TupleType _ | ContractArchType _ | ContractInstanceType _ | VoidType -> false | MappingType _ -> true let count_plain_args (typs : typ list) = List.length (List.filter (fun t -> not (is_mapping t)) typs) let fits_in_one_storage_slot (typ : typ) = match typ with | Uint256Type | Uint8Type | Bytes32Type | AddressType | BoolType | ContractInstanceType _ | MappingType _ -> true | ReferenceType _ -> false | TupleType _ -> false | ContractArchType _ -> false | VoidType -> false let size_of_typ (* in bytes *) = function | Uint256Type -> 32 | Uint8Type -> 1 | Bytes32Type -> 32 | AddressType -> 20 | BoolType -> 32 | ReferenceType _ -> 32 | TupleType lst -> failwith "size_of_typ Tuple" | MappingType _ -> failwith "size_of_typ MappingType" (* XXX: this is just 32 I think *) | ContractArchType x -> failwith ("size_of_typ ContractArchType: "^x) | ContractInstanceType _ -> 20 (* address as word *) | VoidType -> failwith "size_of_typ VoidType should not be asked" let calldata_size_of_typ (typ : typ) = match typ with | MappingType _ -> failwith "mapping cannot be a case argument" | ReferenceType _ -> failwith "reference type cannot be a case argument" | TupleType _ -> failwith "tupletype not implemented" | ContractArchType _ -> failwith "ContractArchType cannot be a case argument" | _ -> size_of_typ typ let calldata_size_of_arg (arg : arg) = calldata_size_of_typ arg.arg_typ let is_throw_only (ss : typ sentence list) : bool = match ss with | [] -> false | [AbortSentence] -> true | _ -> false let non_mapping_arg (arg : arg) = match arg.arg_typ with | MappingType _ -> false | _ -> true let rec functioncall_might_become f = List.concat (List.map exp_might_become f.call_args) and new_exp_might_become n = List.concat (List.map exp_might_become n.new_args)@ (msg_info_might_become n.new_msg_info) and msg_info_might_become m = (match m.message_value_info with | None -> [] | Some e -> exp_might_become e)@ [(* TODO: message_reentrance_info should contain a continuation! *)] and send_exp_might_become s = (exp_might_become s.send_head_contract)@ (List.concat (List.map exp_might_become s.send_args))@ (msg_info_might_become s.send_msg_info) and array_access_might_become aa = exp_might_become aa.array_access_index and exp_might_become e : string list = match fst e with | TrueExp -> [] | FalseExp -> [] | DecLit256Exp _ -> [] | DecLit8Exp _ -> [] | NowExp -> [] | FunctionCallExp f -> functioncall_might_become f | IdentifierExp _ -> [] | ParenthExp content -> exp_might_become content | NewExp n -> new_exp_might_become n | SendExp s -> send_exp_might_become s | LandExp (l, r) -> (exp_might_become l)@(exp_might_become r) | LtExp (l, r) -> (exp_might_become l)@(exp_might_become r) | GtExp (l, r) -> (exp_might_become l)@(exp_might_become r) | NeqExp (l, r) -> (exp_might_become l)@(exp_might_become r) | EqualityExp (l, r) -> (exp_might_become l)@(exp_might_become r) | AddressExp a -> (exp_might_become a) | NotExp n -> exp_might_become n | ArrayAccessExp aa -> lexp_might_become aa | ValueExp -> [] | SenderExp -> [] | ThisExp -> [] | SingleDereferenceExp e -> exp_might_become e | TupleDereferenceExp e -> exp_might_become e | MinusExp (a, b) | MultExp (a, b) | PlusExp (a, b) -> (exp_might_become a)@(exp_might_become b) | BalanceExp a -> exp_might_become a and lexp_might_become l = match l with | ArrayAccessLExp aa -> array_access_might_become aa let variable_init_might_become v = exp_might_become v.variable_init_value let rec sentence_might_become (s : typ sentence) : string list = match s with | AbortSentence -> [] | ReturnSentence ret -> (match ret.return_exp with | Some e -> exp_might_become e | None -> []) @ (exp_might_become ret.return_cont)@ (match contract_name_of_return_cont ret.return_cont with | Some name -> [name] | None -> [] ) | AssignmentSentence (l, r) -> (lexp_might_become l)@ (exp_might_become r) | VariableInitSentence v -> variable_init_might_become v | IfThenOnly (c, block) -> (exp_might_become c)@(sentences_might_become block) | IfThenElse (c, b0, b1) -> (exp_might_become c)@(sentences_might_become b0)@(sentences_might_become b1) | SelfdestructSentence e -> exp_might_become e | ExpSentence e -> exp_might_become e | LogSentence (_, lst, _) -> exps_might_become lst and exps_might_become (lst : typ exp list) : string list = List.concat (List.map exp_might_become lst) and sentences_might_become ss = List.concat (List.map sentence_might_become ss) let case_might_become (case : typ case) : string list = let body = case.case_body in List.concat (List.map sentence_might_become body) let might_become (c : typ contract) : string list = let cases = c.contract_cases in List.concat (List.map case_might_become cases) let lookup_usual_case_in_single_contract c case_name = let cases = c.contract_cases in let cases = List.filter (fun c -> match c.case_header with | DefaultCaseHeader -> false | UsualCaseHeader uc -> uc.case_name = case_name) cases in let () = if (List.length cases = 0) then raise Not_found else if (List.length cases > 1) then let () = Printf.eprintf "case %s duplicated\n%!" case_name in failwith "case_lookup" in match cases with | [] -> raise Not_found | _ :: _ :: _ -> failwith "should not happen" | [a] -> begin match a.case_header with | UsualCaseHeader uc -> uc | DefaultCaseHeader -> failwith "lookup_usual_case_in_single_contract: default case found" end let rec lookup_usual_case_header_inner (already_seen : typ contract list) (c : typ contract) (case_name : string) f : usual_case_header = if List.mem c already_seen then raise Not_found else try lookup_usual_case_in_single_contract c case_name with Not_found -> let already_seen = c :: already_seen in let becomes = List.map f (might_become c) in let rec try_becomes bs already_seen = (match bs with | [] -> raise Not_found | h :: tl -> (try lookup_usual_case_header_inner already_seen h case_name f with Not_found -> let already_seen = h :: already_seen in try_becomes tl already_seen)) in try_becomes becomes already_seen let lookup_usual_case_header (c : typ contract) (case_name : string) f : usual_case_header = lookup_usual_case_header_inner [] c case_name f let size_of_typs (typs : typ list) = WrapList.sum (List.map size_of_typ typs) let acceptable_as t0 t1 = (t0 = t1) || match t0, t1 with | AddressType, ContractInstanceType _ -> true | _, _ -> false ================================================ FILE: src/ast/syntax.mli ================================================ type typ = | VoidType (** the result of calling address.default() *) | Uint256Type | Uint8Type | Bytes32Type | AddressType | BoolType | ReferenceType of typ list (** pointer to [typ list] on memory *) | TupleType of typ list | MappingType of typ * typ | ContractArchType of string (* type of [bid(...)] where bid is a contract *) | ContractInstanceType of string (* type of [b] declared as [bid b] *) type arg = { arg_typ : typ ; arg_ident : string ; arg_location : SideEffect.location option } type event_arg = { event_arg_body : arg ; event_arg_indexed : bool } type event = { event_name : string ; event_arguments : event_arg list } type 'exp_annot function_call = { call_head : string ; call_args : ('exp_annot exp) list } and 'exp_annot message_info = { message_value_info : 'exp_annot exp option ; message_reentrance_info : 'exp_annot sentence list } and 'exp_annot new_exp = { new_head : string ; new_args : 'exp_annot exp list ; new_msg_info : 'exp_annot message_info } and 'exp_annot send_exp = { send_head_contract : 'exp_annot exp ; send_head_method : string option (* None means default *) ; send_args : 'exp_annot exp list ; send_msg_info : 'exp_annot message_info } and 'exp_annot exp = 'exp_annot exp_inner * 'exp_annot and 'exp_annot exp_inner = | TrueExp | FalseExp | DecLit256Exp of WrapBn.t | DecLit8Exp of WrapBn.t | NowExp | FunctionCallExp of 'exp_annot function_call | IdentifierExp of string | ParenthExp of 'exp_annot exp | NewExp of 'exp_annot new_exp | SendExp of 'exp_annot send_exp | LandExp of 'exp_annot exp * 'exp_annot exp | LtExp of 'exp_annot exp * 'exp_annot exp | GtExp of 'exp_annot exp * 'exp_annot exp | NeqExp of 'exp_annot exp * 'exp_annot exp | EqualityExp of 'exp_annot exp * 'exp_annot exp | AddressExp of 'exp_annot exp | NotExp of 'exp_annot exp | ArrayAccessExp of 'exp_annot lexp | ValueExp | SenderExp | ThisExp | SingleDereferenceExp of 'exp_annot exp | TupleDereferenceExp of 'exp_annot exp | PlusExp of 'exp_annot exp * 'exp_annot exp | MinusExp of 'exp_annot exp * 'exp_annot exp | MultExp of 'exp_annot exp * 'exp_annot exp | BalanceExp of 'exp_annot exp and 'exp_annot lexp = | ArrayAccessLExp of 'exp_annot array_access and 'exp_annot array_access = { array_access_array : 'exp_annot exp ; array_access_index : 'exp_annot exp } and 'exp_annot variable_init = { variable_init_type : typ ; variable_init_name : string ; variable_init_value : 'exp_annot exp } and 'exp_annot sentence = | AbortSentence | ReturnSentence of 'exp_annot return | AssignmentSentence of 'exp_annot lexp * 'exp_annot exp | VariableInitSentence of 'exp_annot variable_init | IfThenOnly of 'exp_annot exp * 'exp_annot sentence list | IfThenElse of 'exp_annot exp * 'exp_annot sentence list * 'exp_annot sentence list | SelfdestructSentence of 'exp_annot exp | ExpSentence of 'exp_annot exp | LogSentence of string * 'exp_annot exp list * event option and 'exp_annot return = { return_exp : 'exp_annot exp option ; return_cont : 'exp_annot exp } val read_array_access : 'exp_annot lexp -> 'exp_annot array_access val event_arg_of_arg: arg -> bool -> event_arg val arg_of_event_arg: event_arg -> arg type 'exp_annot case_body = 'exp_annot sentence list type usual_case_header = { case_return_typ : typ list ; case_name : string ; case_arguments : arg list } (** [split_event_args event args] returns [(indexed_args, unindexed_args)] *) val split_event_args : event -> 'a exp list -> ('a exp list * 'a exp list) type case_header = | UsualCaseHeader of usual_case_header | DefaultCaseHeader type 'exp_annot case = { case_header : case_header ; case_body : 'exp_annot case_body } type 'exp_annot contract = { contract_name : string ; contract_arguments : arg list ; contract_cases : 'exp_annot case list } type 'exp_annot toplevel = | Contract of 'exp_annot contract | Event of event val contract_name_of_return_cont : 'exp exp -> string option val case_header_arg_list : case_header -> arg list val contract_name_of_instance : (typ * 'x) exp -> string val string_of_typ : typ -> string val string_of_exp_inner : 'a exp_inner -> string val is_mapping : typ -> bool val count_plain_args : typ list -> int val fits_in_one_storage_slot : typ -> bool val calldata_size_of_arg : arg -> int (** [size_of_typ typ] is the number of bytes that a value of [typ] occupies *) val size_of_typ : typ -> int (** [size_of_typs typs] is the sum of [size_of_typ]s *) val size_of_typs : typ list -> int val is_throw_only : typ sentence list -> bool val non_mapping_arg : arg -> bool (** [lookup_usual_case_header c name f] looks up a case called [name] in the contract [c]. [f] is a function that looks up a contract by its name. *) val lookup_usual_case_header : typ contract -> string -> (string -> typ contract) -> usual_case_header (** [might_become c] lists the name of the contracts that [c] might become, except [c] itself. *) val might_become : typ contract -> string list (** [acceptable_as wanted actual] is true when [actual] is acceptable as [wanted]. *) val acceptable_as : typ -> typ -> bool ================================================ FILE: src/ast/type.ml ================================================ open Syntax let ident_lookup_type (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (tenv : TypeEnv.type_env) id : (typ * SideEffect.t list) exp = match TypeEnv.lookup tenv id with | Some (typ, Some loc) -> (IdentifierExp id, (typ, [loc, SideEffect.Read])) | Some (typ, None) -> (IdentifierExp id, (typ, [])) | None -> failwith ("unknown identifier "^id) (* what should it return when it is a method name? *) let is_known_contract contract_interfaces name = List.exists (fun (_, i) -> i.Contract.contract_interface_name = name) contract_interfaces let rec is_known_type (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (t : typ) = Syntax.( match t with | Uint256Type -> true | Uint8Type -> true | Bytes32Type -> true | AddressType -> true | BoolType -> true | ReferenceType lst -> List.for_all (is_known_type contract_interfaces) lst | TupleType lst -> List.for_all (is_known_type contract_interfaces) lst | MappingType (a, b) -> is_known_type contract_interfaces a && is_known_type contract_interfaces b | ContractArchType contract -> is_known_contract contract_interfaces contract | ContractInstanceType contract -> is_known_contract contract_interfaces contract | VoidType -> true ) let arg_has_known_type contract_interfaces arg = let ret = is_known_type contract_interfaces arg.arg_typ in if not ret then Printf.eprintf "argument has an unknown type %s\n" (Syntax.string_of_typ arg.arg_typ); ret let ret_type_is_known contract_interfaces header = List.for_all (is_known_type contract_interfaces) header.case_return_typ let assign_type_case_header contract_interfaces header = match header with | UsualCaseHeader header -> let () = assert (List.for_all (arg_has_known_type contract_interfaces) header.case_arguments) in let () = assert (ret_type_is_known contract_interfaces header) in UsualCaseHeader header | DefaultCaseHeader -> DefaultCaseHeader let call_arg_expectations (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) mtd : typ list -> bool = match mtd with | "pre_ecdsarecover" -> (fun x -> x = [Bytes32Type; Uint8Type; Bytes32Type; Bytes32Type]) | "keccak256" -> (fun _ -> true) | "iszero" -> (fun x -> x = [Bytes32Type] || x = [Uint8Type] || x = [Uint256Type] || x = [BoolType] || x = [AddressType]) | name -> let cid = Assoc.lookup_id (fun c -> c.Contract.contract_interface_name = name) contract_interfaces in let interface : Contract.contract_interface = Assoc.choose_contract cid contract_interfaces in (fun x -> x = interface.Contract.contract_interface_args) let type_check ((exp : typ), ((_,(t, _)) : (typ * 'a) exp)) = assert (exp = t) let check_args_match (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (args : (typ * 'x) exp list) (call_head : string option) = let expectations : typ list -> bool = match call_head with | Some mtd -> call_arg_expectations contract_interfaces mtd | None -> (fun x -> x = []) in assert (expectations (List.map (fun x -> (fst (snd x))) args)) let typecheck_multiple (exps : typ list) (actual : (typ * 'a) exp list) = List.for_all2 (fun e (_, (a, _)) -> e = a) exps actual let check_only_one_side_effect (llst : SideEffect.t list list) = (* write-write *) if List.length (List.filter (fun x -> List.exists (fun s -> snd s = SideEffect.Write) x ) llst) > 1 then failwith "more than one sub-expressions have side-effects"; (* read-write *) if List.length (List.filter (fun x -> List.exists (fun s -> snd s = SideEffect.Write) x ) llst) = 0 then () else if List.length (List.filter (fun x -> List.exists (fun s -> snd s = SideEffect.Read) x ) llst) > 0 then failwith "some sub-expressions have write effects and some have read effects" let has_no_side_effects (e : (typ * SideEffect.t list) exp) = snd (snd e) = [] let rec assign_type_call contract_interfaces cname venv (src : unit function_call) : ((typ * SideEffect.t list) function_call * (typ * SideEffect.t list)) = let args' = List.map (assign_type_exp contract_interfaces cname venv) src.call_args in let () = check_args_match contract_interfaces args' (Some src.call_head) in let args_side_effects : SideEffect.t list list = List.map (fun (_, (_, s)) -> s) args' in let () = check_only_one_side_effect args_side_effects in let side_effects = (SideEffect.External, SideEffect.Write) :: List.concat args_side_effects in let ret_typ = match src.call_head with | "value" when true (* check the argument is 'msg' *) -> Uint256Type | "pre_ecdsarecover" -> AddressType | "keccak256" -> Bytes32Type | "iszero" -> (match args' with | [arg] -> BoolType | _ -> failwith "should not happen") | contract_name when true (* check the contract exists*) -> ContractArchType contract_name | _ -> failwith "assign_type_call: should not happen" in ({ call_head = src.call_head ; call_args = args' }, (ret_typ, side_effects)) and assign_type_message_info contract_interfaces cname tenv (orig : unit message_info) : (typ * SideEffect.t list) message_info = let v' = WrapOption.map (assign_type_exp contract_interfaces cname tenv) orig.message_value_info in let block' = assign_type_sentences contract_interfaces cname tenv orig.message_reentrance_info in { message_value_info = v' ; message_reentrance_info = block' } and assign_type_exp (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (cname : string) (venv : TypeEnv.type_env) ((exp_inner, ()) : unit exp) : (typ * SideEffect.t list) exp = match exp_inner with | ThisExp -> (ThisExp, (ContractInstanceType cname, [])) | TrueExp -> (TrueExp, (BoolType, [])) | FalseExp -> (FalseExp, (BoolType, [])) | SenderExp -> (SenderExp, (AddressType, [])) | NowExp -> (NowExp, (Uint256Type, [])) | FunctionCallExp c -> let (c', typ) = assign_type_call contract_interfaces cname venv c in (FunctionCallExp c', typ) | DecLit256Exp d -> (DecLit256Exp d, (Uint256Type, [])) | DecLit8Exp d -> (DecLit8Exp d, (Uint8Type, [])) | IdentifierExp s -> (* Now something is strange. This might not need a type anyway. *) (* Maybe introduce a type called CallableType *) let () = if WrapString.starts_with s "pre_" then failwith "names that start with pre_ are reserved" in ident_lookup_type contract_interfaces venv s | ParenthExp e -> (* omit the parenthesis at this place, the tree already contains the structure *) assign_type_exp contract_interfaces cname venv e | NewExp n -> let (n', contract_name) = assign_type_new_exp contract_interfaces cname venv n in let () = if WrapString.starts_with contract_name "pre_" then failwith "names that start with pre_ are reserved" in (NewExp n', (ContractInstanceType contract_name, [SideEffect.External, SideEffect.Write])) | LandExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let () = type_check (BoolType, l) in let r = assign_type_exp contract_interfaces cname venv r in let () = type_check (BoolType, r) in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in (LandExp (l, r), (BoolType, List.concat sides)) | LtExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in let () = assert (fst (snd l) = fst (snd r)) in (LtExp (l, r), (BoolType, List.concat sides)) | GtExp (l, r) -> let l' = assign_type_exp contract_interfaces cname venv l in let r' = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l') = fst (snd r')) in let sides = (List.map (fun (_, (_, x)) -> x) [l'; r']) in let () = check_only_one_side_effect sides in (GtExp (l', r'), (BoolType, List.concat sides)) | NeqExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l) = fst (snd r)) in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in (NeqExp (l, r), (BoolType, List.concat sides)) | EqualityExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l) = fst (snd r)) in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in (EqualityExp (l, r), (BoolType, List.concat sides)) | PlusExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l) = fst (snd r)) in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in (PlusExp (l, r), (fst (snd l), List.concat sides)) | MinusExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l) = fst (snd r)) in let sides = (List.map (fun (_, (_, x)) -> x) [l; r]) in let () = check_only_one_side_effect sides in (MinusExp (l, r), (fst (snd l), List.concat sides)) | MultExp (l, r) -> let l = assign_type_exp contract_interfaces cname venv l in let r = assign_type_exp contract_interfaces cname venv r in let () = assert (fst (snd l) = fst (snd r)) in (MultExp (l, r), snd l) | NotExp negated -> let negated = assign_type_exp contract_interfaces cname venv negated in let () = assert (fst (snd negated) = BoolType) in (NotExp negated, (BoolType, snd (snd negated))) | AddressExp inner -> let inner' = assign_type_exp contract_interfaces cname venv inner in (AddressExp inner', (AddressType, snd (snd inner'))) | BalanceExp inner -> let inner = assign_type_exp contract_interfaces cname venv inner in let () = assert (acceptable_as AddressType (fst (snd inner))) in let () = assert (snd (snd inner) = []) in (BalanceExp inner, (Uint256Type, [SideEffect.External, SideEffect.Read])) | ArrayAccessExp aa -> let atyped = assign_type_exp contract_interfaces cname venv (read_array_access aa).array_access_array in begin match fst (snd atyped) with | MappingType (key_type, value_type) -> let (idx', (idx_typ', idx_side')) = assign_type_exp contract_interfaces cname venv (read_array_access aa).array_access_index in let () = assert (acceptable_as key_type idx_typ') in let () = assert (List.for_all (fun x -> x = (SideEffect.Storage, SideEffect.Read)) idx_side') in (* TODO Check idx_typ' and key_type are somehow compatible *) (ArrayAccessExp (ArrayAccessLExp { array_access_array = atyped ; array_access_index = (idx', (idx_typ', idx_side')) }), (value_type, [SideEffect.Storage, SideEffect.Read])) | _ -> failwith "index access has to be on mappings" end | SendExp send -> let msg_info' = assign_type_message_info contract_interfaces cname venv send.send_msg_info in let contract' = assign_type_exp contract_interfaces cname venv send.send_head_contract in begin match send.send_head_method with | Some mtd -> let contract_name = Syntax.contract_name_of_instance contract' in let method_sig : Ethereum.function_signature = begin match Contract.find_method_signature contract_interfaces contract_name mtd with | Some x -> x | None -> failwith ("method "^mtd^" not found") end in let types = Ethereum.(List.map to_typ (method_sig.sig_return)) in let args = List.map (assign_type_exp contract_interfaces cname venv) send.send_args in let () = assert (List.for_all has_no_side_effects args) in let reference : (Syntax.typ * SideEffect.t list) exp = ( SendExp { send_head_contract = contract' ; send_head_method = send.send_head_method ; send_args = args ; send_msg_info = msg_info' }, (ReferenceType types, [SideEffect.External, SideEffect.Write]) ) in (match types with | [single] -> (SingleDereferenceExp reference, (single, [SideEffect.External, SideEffect.Write])) | _ -> reference) | None -> let () = assert (send.send_args = []) in ( SendExp { send_head_contract = contract' ; send_head_method = None ; send_args = [] ; send_msg_info = msg_info' }, (VoidType, [SideEffect.External, SideEffect.Write]) ) end | ValueExp -> (ValueExp, (Uint256Type, [])) | SingleDereferenceExp _ | TupleDereferenceExp _ -> failwith "DereferenceExp not supposed to appear in the raw tree for now" and assign_type_new_exp contract_interfaces (cname : string) (tenv : TypeEnv.type_env) (e : unit new_exp) : ((typ * SideEffect.t list) new_exp * string (* name of the contract just created *)) = let msg_info' = assign_type_message_info contract_interfaces cname tenv e.new_msg_info in let args' = List.map (assign_type_exp contract_interfaces cname tenv) e.new_args in let e' = { new_head = e.new_head ; new_args = args' ; new_msg_info = msg_info' } in (e', e.new_head ) and assign_type_lexp contract_interfaces (cname : string) venv (src : unit lexp) : (typ * SideEffect.t list) lexp = (* no need to type the left hand side? *) match src with | ArrayAccessLExp aa -> let atyped = assign_type_exp contract_interfaces cname venv aa.array_access_array in begin match fst (snd atyped) with | MappingType (key_type, value_type) -> let (idx', idx_typ') = assign_type_exp contract_interfaces cname venv aa.array_access_index in (* TODO Check idx_typ' and key_type are somehow compatible *) (ArrayAccessLExp { array_access_array = atyped ; array_access_index = (idx', idx_typ')}) | _ -> failwith ("unknown array") end and assign_type_return (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (cname : string) (tenv : TypeEnv.type_env) (src : unit return) : (typ * SideEffect.t list) return = let exps = WrapOption.map (assign_type_exp contract_interfaces cname tenv) src.return_exp in let f = TypeEnv.lookup_expected_returns tenv in let () = assert (f (WrapOption.map (fun x -> (fst (snd x))) exps)) in { return_exp = exps ; return_cont = assign_type_exp contract_interfaces cname tenv src.return_cont } and type_variable_init contract_interfaces cname tenv (vi : unit variable_init) : ((typ * SideEffect.t list) variable_init * TypeEnv.type_env) = (* This function has to enlarge the type environment *) let value' = assign_type_exp contract_interfaces cname tenv vi.variable_init_value in let added_name = vi.variable_init_name in let () = if WrapString.starts_with added_name "pre_" then failwith "names that start with pre_ are reserved" in let added_typ = vi.variable_init_type in let () = assert (is_known_type contract_interfaces added_typ) in let new_env = TypeEnv.add_pair tenv added_name added_typ None in let new_init = { variable_init_type = added_typ ; variable_init_name = added_name ; variable_init_value = value' } in (new_init, new_env) and assign_type_sentence (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (cname : string) (venv : TypeEnv.type_env) (src : unit sentence) : ((typ * SideEffect.t list) sentence * TypeEnv.type_env (* updated environment *)) = match src with | AbortSentence -> (AbortSentence, venv) | ReturnSentence r -> let r' = assign_type_return contract_interfaces cname venv r in (ReturnSentence r', venv) | AssignmentSentence (l, r) -> let l' = assign_type_lexp contract_interfaces cname venv l in let r' = assign_type_exp contract_interfaces cname venv r in (AssignmentSentence (l', r'), venv) | IfThenOnly (cond, ss) -> let cond' = assign_type_exp contract_interfaces cname venv cond in let ss' = assign_type_sentences contract_interfaces cname venv ss in (IfThenOnly (cond', ss'), venv) | IfThenElse (cond, sst, ssf) -> let cond' = assign_type_exp contract_interfaces cname venv cond in let sst' = assign_type_sentences contract_interfaces cname venv sst in let ssf' = assign_type_sentences contract_interfaces cname venv ssf in (IfThenElse (cond', sst', ssf'), venv) | SelfdestructSentence e -> let e' = assign_type_exp contract_interfaces cname venv e in (SelfdestructSentence e', venv) | VariableInitSentence vi -> let (vi', venv') = type_variable_init contract_interfaces cname venv vi in (VariableInitSentence vi', venv') | ExpSentence exp -> let exp = assign_type_exp contract_interfaces cname venv exp in let () = assert (fst (snd exp) = VoidType) in let () = assert (List.exists (fun (_, x) -> x = SideEffect.Write) (snd (snd exp))) in (ExpSentence exp, venv) | LogSentence (name, args, _) -> let args = List.map (assign_type_exp contract_interfaces cname venv) args in let event = TypeEnv.lookup_event venv name in let type_expectations = List.map (fun ea -> Syntax.(ea.event_arg_body.arg_typ)) event.Syntax.event_arguments in let () = assert (typecheck_multiple type_expectations args) in let side_effects = List.map (fun (_, (_, a)) -> a) args in let () = check_only_one_side_effect side_effects in (LogSentence (name, args, Some event), venv) and assign_type_sentences (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (cname : string) (type_environment : TypeEnv.type_env) (ss : unit sentence list) : (typ * SideEffect.t list) sentence list = match ss with | [] -> [] | first_s :: rest_ss -> let (first_s', (updated_environment : TypeEnv.type_env)) = assign_type_sentence contract_interfaces cname type_environment first_s in first_s' :: assign_type_sentences contract_interfaces cname updated_environment rest_ss type termination = RunAway | ReturnValues of int | JustStop let rec is_terminating_sentence (s : unit sentence) : termination list = match s with | AbortSentence -> [JustStop] | ReturnSentence ret -> begin match ret.return_exp with | Some _ -> [ReturnValues 1] | None -> [ReturnValues 0] end | AssignmentSentence _ -> [RunAway] | VariableInitSentence _ -> [RunAway] | IfThenOnly (_, b) -> (are_terminating b) @ [RunAway] (* there is a continuation if the condition does not hold. *) | IfThenElse (_, bT, bF) -> are_terminating bT @ (are_terminating bF) | SelfdestructSentence _ -> [JustStop] | ExpSentence _ -> [RunAway] | LogSentence _ -> [RunAway] (** [check_termination sentences] make sure that the last sentence in [sentences] * cuts the continuation. *) and are_terminating sentences = let last_sentence = WrapList.last sentences in is_terminating_sentence last_sentence let case_is_returning_void (case : unit case) : bool = match case.case_header with | DefaultCaseHeader -> true | UsualCaseHeader u -> u.case_return_typ = [] let return_expectation_of_case (h : Syntax.case_header) (actual : Syntax.typ option) : bool = match h, actual with | DefaultCaseHeader, Some _ -> false | DefaultCaseHeader, None -> true | UsualCaseHeader u, _ -> begin match u.case_return_typ, actual with | _ :: _ :: _, _ -> false | [x], Some y -> Syntax.acceptable_as x y | [], None -> true | _, _ ->false end let assign_type_case (contract_interfaces : Contract.contract_interface Assoc.contract_id_assoc) (contract_name : string) (venv : TypeEnv.type_env) (case : unit case) = let () = assert (List.for_all (fun t -> match t with | RunAway -> false | ReturnValues 0 -> case_is_returning_void case | ReturnValues 1 -> not (case_is_returning_void case) | ReturnValues _ -> failwith "returning multiple values not supported yet" | JustStop -> true ) (are_terminating case.case_body)) in let case_arguments = case_header_arg_list case.case_header in let () = if List.exists (fun arg -> WrapString.starts_with arg.arg_ident "pre_") case_arguments then failwith "names that start with pre_ are reserved" in let returns : Syntax.typ option -> bool = return_expectation_of_case case.case_header in { case_header = assign_type_case_header contract_interfaces case.case_header ; case_body = assign_type_sentences contract_interfaces contract_name (TypeEnv.remember_expected_returns (TypeEnv.add_block case_arguments venv) returns) case.case_body } let has_distinct_signatures (c : unit Syntax.contract) : bool = let cases = c.contract_cases in let signatures = List.map (fun c -> match c.case_header with | UsualCaseHeader u -> Some (Ethereum.case_header_signature_string u) | DefaultCaseHeader -> None) cases in let unique_sig = WrapList.unique signatures in List.length signatures = List.length unique_sig let assign_type_contract (env : Contract.contract_interface Assoc.contract_id_assoc) (events: event Assoc.contract_id_assoc) (raw : unit Syntax.contract) : (Syntax.typ * SideEffect.t list) Syntax.contract = let () = assert (List.for_all (arg_has_known_type env) raw.contract_arguments) in let () = assert (has_distinct_signatures raw) in let tenv = TypeEnv.(add_block raw.contract_arguments (add_events events empty_type_env)) in let () = if WrapString.starts_with raw.contract_name "pre_" then failwith "names that start with pre_ are reserved" in let () = if List.exists (fun arg -> WrapString.starts_with arg.arg_ident "pre_") raw.contract_arguments then failwith "names that start with pre_ are reserved" in { contract_name = raw.contract_name ; contract_arguments = raw.contract_arguments ; contract_cases = List.map (assign_type_case env raw.contract_name tenv) raw.contract_cases } let assign_type_toplevel (interfaces : Contract.contract_interface Assoc.contract_id_assoc) (events : event Assoc.contract_id_assoc) (raw : unit Syntax.toplevel) : (Syntax.typ * SideEffect.t list) Syntax.toplevel = match raw with | Contract c -> Contract (assign_type_contract interfaces events c) | Event e -> Event e (* XXX: these [strip_side_effects_X] should be generalized over any f : 'a -> 'b *) let rec strip_side_effects_sentence (raw : (typ * 'a) sentence) : typ sentence = match raw with | AbortSentence -> AbortSentence | ReturnSentence ret -> ReturnSentence (strip_side_effects_return ret) | AssignmentSentence (l, r) -> AssignmentSentence (strip_side_effects_lexp l, strip_side_effects_exp r) | VariableInitSentence v -> VariableInitSentence (strip_side_effects_variable_init v) | IfThenOnly (e, block) -> IfThenOnly (strip_side_effects_exp e, strip_side_effects_case_body block) | IfThenElse (e, b0, b1) -> IfThenElse ((strip_side_effects_exp e), (strip_side_effects_case_body b0), (strip_side_effects_case_body b1)) | SelfdestructSentence e -> SelfdestructSentence (strip_side_effects_exp e) | ExpSentence e -> ExpSentence (strip_side_effects_exp e) | LogSentence (str, args, eopt) -> LogSentence (str, List.map strip_side_effects_exp args, eopt) and strip_side_effects_variable_init v = { variable_init_type = v.variable_init_type ; variable_init_name = v.variable_init_name ; variable_init_value = strip_side_effects_exp v.variable_init_value } and strip_side_effects_aa aa = { array_access_array = strip_side_effects_exp aa.array_access_array ; array_access_index = strip_side_effects_exp aa.array_access_index } and strip_side_effects_lexp lexp = match lexp with | ArrayAccessLExp aa -> ArrayAccessLExp (strip_side_effects_aa aa) and strip_side_effects_exp (i, (t, _)) = (strip_side_effects_exp_inner i, t) and strip_side_effects_function_call fc = { call_head = fc.call_head ; call_args = List.map strip_side_effects_exp fc.call_args } and strip_side_effects_msg_info m = { message_value_info = WrapOption.map strip_side_effects_exp m.message_value_info ; message_reentrance_info = List.map strip_side_effects_sentence m.message_reentrance_info } and strip_side_effects_send s = { send_head_contract = strip_side_effects_exp s.send_head_contract ; send_head_method = s.send_head_method ; send_args = List.map strip_side_effects_exp s.send_args ; send_msg_info = strip_side_effects_msg_info s.send_msg_info } and strip_side_effects_new_exp n = { new_head = n.new_head ; new_args = List.map strip_side_effects_exp n.new_args ; new_msg_info = strip_side_effects_msg_info n.new_msg_info } and strip_side_effects_exp_inner i = match i with | TrueExp -> TrueExp | FalseExp -> FalseExp | DecLit256Exp d -> DecLit256Exp d | DecLit8Exp d -> DecLit8Exp d | NowExp -> NowExp | FunctionCallExp fc -> FunctionCallExp (strip_side_effects_function_call fc) | IdentifierExp str -> IdentifierExp str | ParenthExp e -> ParenthExp (strip_side_effects_exp e) | NewExp e -> NewExp (strip_side_effects_new_exp e) | SendExp send -> SendExp (strip_side_effects_send send) | LandExp (a, b) -> LandExp (strip_side_effects_exp a, strip_side_effects_exp b) | LtExp (a, b) -> LtExp (strip_side_effects_exp a, strip_side_effects_exp b) | GtExp (a, b) -> GtExp (strip_side_effects_exp a, strip_side_effects_exp b) | NeqExp (a, b) -> NeqExp (strip_side_effects_exp a, strip_side_effects_exp b) | EqualityExp (a, b) -> EqualityExp (strip_side_effects_exp a, strip_side_effects_exp b) | AddressExp a -> AddressExp (strip_side_effects_exp a) | NotExp e -> NotExp (strip_side_effects_exp e) | ArrayAccessExp l -> ArrayAccessExp (strip_side_effects_lexp l) | ValueExp -> ValueExp | SenderExp -> SenderExp | ThisExp -> ThisExp | SingleDereferenceExp e -> SingleDereferenceExp (strip_side_effects_exp e) | TupleDereferenceExp e -> TupleDereferenceExp (strip_side_effects_exp e) | PlusExp (a, b) -> PlusExp (strip_side_effects_exp a, strip_side_effects_exp b) | MinusExp (a, b) -> MinusExp (strip_side_effects_exp a, strip_side_effects_exp b) | MultExp (a, b) -> MultExp (strip_side_effects_exp a, strip_side_effects_exp b) | BalanceExp e -> BalanceExp (strip_side_effects_exp e) and strip_side_effects_return ret = { return_exp = WrapOption.map strip_side_effects_exp ret.return_exp ; return_cont = strip_side_effects_exp ret.return_cont } and strip_side_effects_case_body (raw : (typ * 'a) case_body) : typ case_body = List.map strip_side_effects_sentence raw let strip_side_effects_case (raw : (typ * 'a) case) : typ case = { case_header = raw.case_header ; case_body = strip_side_effects_case_body raw.case_body } let strip_side_effects_contract (raw : (typ * 'a) contract) : typ contract = { contract_name = raw.contract_name ; contract_arguments = raw.contract_arguments ; contract_cases = List.map strip_side_effects_case raw.contract_cases } let strip_side_effects (raw : (typ * 'a) Syntax.toplevel) : typ Syntax.toplevel = match raw with | Contract c -> Contract (strip_side_effects_contract c) | Event e -> Event e let has_distinct_contract_names (contracts : unit Syntax.contract Assoc.contract_id_assoc) : bool = let contract_names = (List.map (fun (_, b) -> b.Syntax.contract_name) contracts) in List.length contracts = List.length (WrapList.unique contract_names) let assign_types (raw : unit Syntax.toplevel Assoc.contract_id_assoc) : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc = let raw_contracts : unit Syntax.contract Assoc.contract_id_assoc = Assoc.filter_map (fun x -> match x with | Contract c -> Some c | _ -> None ) raw in let () = assert(has_distinct_contract_names(raw_contracts)) in let interfaces = Assoc.map Contract.contract_interface_of raw_contracts in let events : event Assoc.contract_id_assoc = Assoc.filter_map (fun x -> match x with | Event e -> Some e | _ -> None) raw in Assoc.map strip_side_effects (Assoc.map (assign_type_toplevel interfaces events) raw) ================================================ FILE: src/ast/type.mli ================================================ val assign_types : unit Syntax.toplevel Assoc.contract_id_assoc -> Syntax.typ Syntax.toplevel Assoc.contract_id_assoc ================================================ FILE: src/ast/typeEnv.ml ================================================ (** The first element is the context for the innermost block *) type type_env = { identifiers: Syntax.arg list list ; events: Syntax.event list ; expected_returns : (Syntax.typ option -> bool) option } let empty_type_env : type_env = { identifiers = [] ; events = [] ; expected_returns = None } let forget_innermost (orig : type_env) : type_env = { orig with identifiers = List.tl (orig.identifiers) } let add_empty_block (orig : type_env) : type_env = { orig with identifiers = [] :: orig.identifiers } let add_pair (orig : type_env) (ident : string) (typ : Syntax.typ) (loc : SideEffect.location option) : type_env = match orig.identifiers with | h :: t -> { orig with identifiers = (Syntax.{ arg_ident = ident; arg_typ = typ; arg_location = loc} :: h) :: t } | _ -> failwith "no current scope in type env" let lookup_block (name : string) (block : Syntax.arg list) = Misc.first_some (fun (a : Syntax.arg) -> if a.Syntax.arg_ident = name then Some (a.Syntax.arg_typ, a.Syntax.arg_location) else None) block let lookup (env : type_env) (name : string) : (Syntax.typ * SideEffect.location option) option = Misc.first_some (lookup_block name) env.identifiers let add_block (h : Syntax.arg list) (orig : type_env) : type_env = { orig with identifiers = h :: orig.identifiers } let lookup_event (env : type_env) (name : string) : Syntax.event = try List.find (fun e -> e.Syntax.event_name = name) env.events with Not_found -> let () = Printf.eprintf "event %s not found\n" name in raise Not_found let add_events (events : Syntax.event Assoc.contract_id_assoc) (orig : type_env) : type_env = { orig with events = (Assoc.values events) @ orig.events } let remember_expected_returns (orig : type_env) f = match orig.expected_returns with | Some _ -> failwith "Trying to overwrite the expectations about the return values" | None -> { orig with expected_returns = Some f } let lookup_expected_returns t = match t.expected_returns with | None -> failwith "undefined" | Some f -> f ================================================ FILE: src/ast/typeEnv.mli ================================================ type type_env val empty_type_env : type_env val forget_innermost : type_env -> type_env val add_empty_block : type_env -> type_env val add_pair : type_env -> string -> Syntax.typ -> SideEffect.location option -> type_env val lookup : type_env -> string -> (Syntax.typ * SideEffect.location option) option val add_block : Syntax.arg list -> type_env -> type_env val lookup_event : type_env -> string -> Syntax.event val add_events : Syntax.event Assoc.contract_id_assoc -> type_env -> type_env val remember_expected_returns : type_env -> (Syntax.typ option -> bool) -> type_env val lookup_expected_returns : type_env -> (Syntax.typ option -> bool) ================================================ FILE: src/basics/META ================================================ # OASIS_START # DO NOT EDIT (digest: 3b4490fa7dbdc2ad5da8665d7c5224d8) version = "0.0.03" description = "A compiler targeting Ethereum Virtual Machine" requires = "cross-platform" archive(byte) = "basics.cma" archive(byte, plugin) = "basics.cma" archive(native) = "basics.cmxa" archive(native, plugin) = "basics.cmxs" exists_if = "basics.cma" # OASIS_STOP ================================================ FILE: src/basics/assoc.ml ================================================ type contract_id = int type 'a contract_id_assoc = (contract_id * 'a) list let list_to_contract_id_assoc (lst : 'a list) = let ids = if lst = [] then [] else WrapList.range 0 (List.length lst - 1) in List.combine ids lst let map f lst = List.map (fun (id, x) -> (id, f x)) lst let pair_map f lst = List.map (fun (id, x) -> (id, f id x)) lst let filter_map f lst = WrapList.filter_map ( fun (id, x) -> WrapOption.map (fun ret -> (id, ret)) (f x)) lst let choose_contract (id : contract_id) lst = try List.assoc id lst with Not_found -> let () = Printf.eprintf "choose_contract: not_found\n%!" in raise Not_found let print_int_for_cids (f : contract_id -> int) (cids : contract_id list) : unit = List.iter (fun cid -> Printf.printf "%d |-> %d, " cid (f cid)) cids let insert (id : contract_id) (a : 'x) (orig : 'x contract_id_assoc) : 'x contract_id_assoc = (id, a)::orig (* shall I sort it? Maybe later at once. *) let lookup_id (f : 'x -> bool) (lst : 'x contract_id_assoc) : contract_id = let (id, _) = List.find (fun (_, x) -> f x) lst in id let empty = [] let cids lst = List.map fst lst let values lst = List.map snd lst ================================================ FILE: src/basics/assoc.mli ================================================ type contract_id = int (* Currently, the location in [contracts] *) type 'a contract_id_assoc = (contract_id * 'a) list (** [list_to_contract_id_assoc] assignes a different contract_id for each element of the list. * It starts with 0 until (length of list - 1). *) val list_to_contract_id_assoc : 'a list -> 'a contract_id_assoc val map : ('a -> 'b) -> 'a contract_id_assoc -> 'b contract_id_assoc val pair_map : (contract_id -> 'a -> 'b) -> 'a contract_id_assoc -> 'b contract_id_assoc val filter_map : ('a -> 'b option) -> 'a contract_id_assoc -> 'b contract_id_assoc val choose_contract : contract_id -> 'x contract_id_assoc -> 'x val print_int_for_cids : (contract_id -> int) -> contract_id list -> unit val insert : contract_id -> 'x -> 'x contract_id_assoc -> 'x contract_id_assoc val lookup_id : ('x -> bool) -> 'x contract_id_assoc -> contract_id val empty : 'x contract_id_assoc val cids : 'x contract_id_assoc -> contract_id list val values : 'x contract_id_assoc -> 'x list ================================================ FILE: src/basics/basics.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: 544c3466c83774053c2a71824a587891) Assoc Hexa Label Misc Storage # OASIS_STOP ================================================ FILE: src/basics/basics.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: 544c3466c83774053c2a71824a587891) Assoc Hexa Label Misc Storage # OASIS_STOP ================================================ FILE: src/basics/hex_test.ml ================================================ open Hexa open Evm let _ = let () = Printf.printf "testing hex\n" in let () = assert (string_of_hex empty_hex = "") in let one_hex = hex_of_big_int WrapBn.(big_int_of_int 1) 1 in let () = assert (string_of_hex one_hex = "01") in let () = assert (string_of_hex (concat_hex one_hex one_hex) = "0101") in let () = assert (length_of_hex one_hex = 1) in let () = assert (string_of_hex (hex_of_instruction STOP) = "00") in let () = assert (string_of_hex (hex_of_program [STOP; RETURN]) = "f300") in () ================================================ FILE: src/basics/hexa.ml ================================================ type hex = Rope.t let empty_hex = Rope.empty let concat_hex = Rope.concat2 let length_of_hex h = Rope.length h / 2 let hex_of_big_int (b : WrapBn.t) (length : int) = let raw = WrapBn.to_string_in_hexa b in let char_limit = 2 * length in let () = if String.length raw > char_limit then failwith "hex_of_big_int: too big" in let missing_len = char_limit - String.length raw in let prefix = String.make missing_len '0' in concat_hex (Rope.of_string prefix) (Rope.of_string raw) let string_of_hex ?prefix:(prefix : string = "") (h : hex) : string = let ret = concat_hex (Rope.of_string prefix) h in Rope.to_string ret let print_hex ?prefix:(prefix = "") h = Printf.printf "%s\n" (string_of_hex ~prefix h) let hex_of_string s = (* TODO: check if the string contains only 0-9a-fA-F *) Rope.of_string s ================================================ FILE: src/basics/hexa.mli ================================================ type hex val empty_hex : hex val concat_hex : hex -> hex -> hex (** [length_of_hex h] returns the length of [h] as the number of the represented bytes. * This implies [length_of_hex h] is always the half of the length of [string_of_hex h]. *) val length_of_hex : hex -> int (** [hex_of_big_int b l] returns the hex, which is zero-padded to [2 * l] characters. * If [b] is too big, raises a failure. *) val hex_of_big_int : WrapBn.t -> int -> hex (** [hex_of_string "0101"] is the hex "0x0101" *) val hex_of_string : string -> hex val string_of_hex : ?prefix:string -> hex -> string val print_hex : ?prefix:string -> hex -> unit ================================================ FILE: src/basics/label.ml ================================================ type label = int let debug_label = false (* internal data not accessible from outside of the module. *) let next_fresh_label : int ref = ref 0 let store : (label * int) list ref = ref [] let new_label () = let ret = !next_fresh_label in let () = if debug_label then Printf.printf "label: generating label %d\n" ret else () in let () = next_fresh_label := ret + 1 in ret let register_value l i = let () = if debug_label then Printf.printf "label: registering label %d %d\n%!" l i in store := (l, i) :: !store let lookup_value l = try List.assoc l !store with Not_found -> let () = if debug_label then Printf.eprintf "label: %d not found\n%!" l in raise Not_found ================================================ FILE: src/basics/label.mli ================================================ (* A label is typically put on a jump destination. *) type label (** [new label ()] returns a new label each time it is called. *) val new_label : unit -> label (** [register_value l i] registers a correspondence (l, i). * If [register_location l j] is already called * (even if j is equal to i), throws a failure *) val register_value : label -> int -> unit (** [lookup_value l] returns the value [i] with which * the correspondence [(l, i)] has been registered. * When such correspondence does not exist, * throws a failure. *) val lookup_value : label -> int ================================================ FILE: src/basics/misc.ml ================================================ let rec first_some f lst = match lst with | [] -> None | h :: t -> begin match f h with | None -> first_some f t | Some x -> Some x end let rec change_first f lst = match lst with | [] -> None | h :: t -> begin match f h with | None -> WrapOption.map (fun rest -> h :: rest) (change_first f t) | Some n -> Some (n :: t) end ================================================ FILE: src/basics/misc.mli ================================================ (** If any element is mapped to [Some x], return the first such one. Otherwise return [None]. *) val first_some : ('a -> 'b option) -> 'a list -> 'b option (** If any element is mapped to [Some x], replace the first such element with [x]. Otherwise, return [None] *) val change_first : ('a -> 'a option) -> 'a list -> 'a list option ================================================ FILE: src/basics/storage.ml ================================================ type storage_location = int ================================================ FILE: src/basics/storage.mli ================================================ type storage_location = int ================================================ FILE: src/codegen/META ================================================ # OASIS_START # DO NOT EDIT (digest: 5601d8fffa94038ded43ae8629ffa980) version = "0.0.03" description = "A compiler targeting Ethereum Virtual Machine" requires = "basics ast parse" archive(byte) = "codegen.cma" archive(byte, plugin) = "codegen.cma" archive(native) = "codegen.cmxa" archive(native, plugin) = "codegen.cmxs" exists_if = "codegen.cma" # OASIS_STOP ================================================ FILE: src/codegen/codegen.ml ================================================ open PseudoImm open CodegenEnv open Evm open Syntax let copy_storage_range_to_stack_top le ce (range : PseudoImm.pseudo_imm Location.storage_range) = let () = assert (PseudoImm.is_constant_int 1 range.Location.storage_size) in let offset : PseudoImm.pseudo_imm = range.Location.storage_start in let ce = append_instruction ce (PUSH32 offset) in let ce = append_instruction ce SLOAD in (le, ce) let copy_stack_to_stack_top le ce (s : int) = let original_stack_size = stack_size ce in let diff = original_stack_size - s in let () = assert (diff >= 0) in let ce = append_instruction ce (Evm.dup_suc_n diff) in let () = assert (stack_size ce = original_stack_size + 1) in le, ce let append_label ce label = append_instruction ce (PUSH4 (DestLabel label)) let shift_stack_top_to_right ce bits = let () = assert (bits >= 0) in let () = assert (bits < 256) in if bits = 0 then ce else (* [x] *) let ce = append_instruction ce (PUSH1 (Int bits)) in (* [x, bits] *) let ce = append_instruction ce (PUSH1 (Int 2)) in (* [x, bits, 2] *) let ce = append_instruction ce EXP in (* [x, 2 ** bits] *) let ce = append_instruction ce SWAP1 in (* [2 ** bits, x] *) let ce = append_instruction ce DIV in (* [x / (2 ** bits)] *) ce let shift_stack_top_to_left ce bits = let () = assert (bits >= 0) in let () = assert (bits < 256) in if bits = 0 then ce else (* [x] *) let ce = append_instruction ce (PUSH1 (Int bits)) in (* [x, bits] *) let ce = append_instruction ce (PUSH1 (Int 2)) in (* [x, bits, 2] *) let ce = append_instruction ce EXP in (* [x, 2 ** bits] *) let ce = append_instruction ce MUL in (* [(2 ** bits) * x] *) ce let copy_calldata_to_stack_top le ce (range : Location.calldata_range) = let () = assert (range.Location.calldata_size > 0) in let () = assert (range.Location.calldata_size <= 32) in let ce = append_instruction ce (PUSH4 (Int range.Location.calldata_offset)) in let ce = append_instruction ce CALLDATALOAD in let ce = shift_stack_top_to_right ce ((32 - range.Location.calldata_size) * 8) in le, ce type alignment = LeftAligned | RightAligned let align_boolean ce alignment = let () = assert (alignment = RightAligned) in ce let align_address ce alignment = match alignment with RightAligned -> ce | LeftAligned -> shift_stack_top_to_left ce (12 * 8) let align_from_right_aligned (ce : CodegenEnv.t) alignment typ = match alignment with | RightAligned -> ce | LeftAligned -> let size = size_of_typ typ in let () = assert (size <= 32) in if size = 32 then ce else let shift = (32 - size) * 8 in let ce = append_instruction ce (PUSH1 (Int shift)) in (* stack: [shift] *) let ce = append_instruction ce (PUSH1 (Int 2)) in (* stack: [shift, 2] *) let ce = append_instruction ce EXP in (* stack: [2 ** shift] *) let ce = append_instruction ce MUL in ce let copy_to_stack_top le ce alignment typ (l : Location.location) = let le, ce = Location.( match l with | Storage range -> copy_storage_range_to_stack_top le ce range | CachedStorage _ -> failwith "copy_to_stack_top: CachedStorage" | Volatile _ -> failwith "copy_to_stack_top: Volatile" | Code _ -> failwith "copy_to_stack_top: Code" | Calldata range -> copy_calldata_to_stack_top le ce range | Stack s -> copy_stack_to_stack_top le ce s ) in let ce = align_from_right_aligned ce alignment typ in (* le needs to remember the alignment *) le, ce let swap_entrance_pc_with_zero ce = let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce SLOAD in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce DUP1 in let ce = append_instruction ce SSTORE in ce (** [restore_entrance_pc] moves the topmost stack element to the entrance pc *) let restore_entrance_pc ce = let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce SSTORE in ce (** [throw_if_zero] peeks the topmost stack element and throws if it's zero *) let throw_if_zero ce = let ce = append_instruction ce DUP1 in let ce = append_instruction ce ISZERO in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce JUMPI in ce (** [push_allocated_memory] behaves like an instruction * that takes a desired memory size as an argument. * This pushes the allocated address. *) let push_allocated_memory (ce : CodegenEnv.t) = let original_stack_size = stack_size ce in (* [desired_length] *) let ce = append_instruction ce (PUSH1 (Int 64)) in let ce = append_instruction ce DUP1 in (* [desired_length, 64, 64] *) let ce = append_instruction ce MLOAD in (* [desired_length, 64, memory[64]] *) let ce = append_instruction ce DUP1 in (* [desired_length, 64, memory[64], memory[64]] *) let ce = append_instruction ce SWAP3 in (* [memory[64], 64, memory[64], desired_length] *) let ce = append_instruction ce ADD in (* [memory[64], 64, new_head] *) let ce = append_instruction ce SWAP1 in (* [memory[64], new_head, 64] *) let ce = append_instruction ce MSTORE in (* [memory[64]] *) let () = assert (stack_size ce = original_stack_size) in ce let peek_next_memory_allocation (ce : CodegenEnv.t) = let original_stack_size = stack_size ce in (* [] *) let ce = append_instruction ce (PUSH1 (Int 64)) in let ce = append_instruction ce MLOAD in let () = assert (stack_size ce = 1 + original_stack_size) in ce (** [Tight] just uses [size_of_typ] bytes on the memory. * [ABI] always uses multiples of 32 bytes. * These choices do not affect the alighments *) type memoryPacking = TightPacking | ABIPacking let copy_from_code_to_memory ce = (* stack: [codesize, codeoffset] *) let ce = append_instruction ce DUP2 in (* stack: [codesize, codeoffset, codesize] *) let ce = push_allocated_memory ce in (* stack: [codesize, codeoffset, memory_address] *) let ce = append_instruction ce SWAP1 in (* stack: [codesize, memory_address, codeoffset] *) let ce = append_instruction ce DUP3 in (* stack: [codesize, memory_address, codeoffset, codesize] *) let ce = append_instruction ce SWAP1 in (* stack: [codesize, memory_address, codesize, codeoffset] *) let ce = append_instruction ce DUP3 in (* stack: [codesize, memory_address, codesize, codeoffset, memory_address] *) let ce = append_instruction ce CODECOPY in (* stack: [codesize, memory_address] *) ce (** [copy_whole_current_code_to_memory] allocates enough memory to accomodate the * whole of the currently running code, and copies it there. * After this, [size, offset] of the memory region is left on the stack. *) let copy_whole_current_code_to_memory ce = let original_stack_size = stack_size ce in let ce = append_instruction ce CODESIZE in (* stack: [size] *) let ce = append_instruction ce DUP1 in (* stack: [size, size] *) let ce = push_allocated_memory ce in (* stack: [size, offset] *) let ce = append_instruction ce DUP2 in (* stack: [size, offset, codesize] *) let ce = append_instruction ce (PUSH1 (Int 0)) in (* stack: [size, offset, codesize, 0] *) let ce = append_instruction ce DUP3 in (* stack: [size, offset, codesize, 0, offset] *) let ce = append_instruction ce CODECOPY in (* stack: [size, offset] *) let () = assert(original_stack_size + 2 = stack_size ce) in ce let push_signature_code (ce : CodegenEnv.t) (case_signature : usual_case_header) = let hash = Ethereum.case_header_signature_hash case_signature in let ce = append_instruction ce (PUSH4 (Big (WrapBn.hex_to_big_int hash))) in ce (** [prepare_functiohn_signature ce usual_header] * Allocates 4 bytes on the memory, and puts the function signature of the argument there. * After that, the stack has (..., signature size, signature offset ) *) let prepare_function_signature ce usual_header = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH1 (Int 4)) in (* stack : (..., 4) *) let ce = append_instruction ce DUP1 in (* stack : (..., 4, 4) *) let ce = push_allocated_memory ce in (* stack : (..., 4, signature_offset) *) let ce = push_signature_code ce usual_header in (* stack : (..., 4, signature_offset, sig) *) let ce = append_instruction ce DUP2 in (* stack : (..., 4, signature_offset, sig, signature_offset) *) let ce = append_instruction ce MSTORE in (* stack : (..., 4, signature_offset) *) let () = assert (stack_size ce = original_stack_size + 2) in ce let keccak_cons le ce = let original_stack_size = stack_size ce in (* put the top into 0x00 *) let ce = append_instruction ce (PUSH1 (Int 0x0)) in let ce = append_instruction ce MSTORE in (* put the top into 0x20 *) let ce = append_instruction ce (PUSH1 (Int 0x20)) in let ce = append_instruction ce MSTORE in (* take the sah3 of 0x00--0x40 *) let ce = append_instruction ce (PUSH1 (Int 0x40)) in let ce = append_instruction ce (PUSH1 (Int 0x0)) in let ce = append_instruction ce SHA3 in let () = assert (stack_size ce + 1 = original_stack_size) in ce let increase_top ce (inc : int) = let ce = append_instruction ce (PUSH32 (Int inc)) in let ce = append_instruction ce ADD in ce (** [add_constructor_argument_to_memory ce arg] realizes [arg] on the memory * according to the ABI. This increases the stack top element by the size of the * new allocation. *) let rec add_constructor_argument_to_memory le (packing : memoryPacking) ce (arg : Syntax.typ exp) = let original_stack_size = stack_size ce in let typ = snd arg in let () = assert (Syntax.fits_in_one_storage_slot typ) in (* stack : [acc] *) let ce = append_instruction ce (PUSH1 (Int (match packing with | ABIPacking -> 32 | TightPacking -> Syntax.size_of_typ typ))) in (* stack : [acc, size] *) let ce = append_instruction ce DUP1 in (* stack : [acc, size, size] *) let ce = push_allocated_memory ce in (* stack : [acc, size, offset] *) let ce = codegen_exp le ce (match packing with | ABIPacking -> RightAligned | TightPacking -> LeftAligned ) arg in (* stack : [acc, size, offset, val] *) let ce = append_instruction ce SWAP1 in (* stack : [acc, size, val, offset] *) let ce = append_instruction ce MSTORE in (* stack : [acc, size] *) let ce = append_instruction ce ADD in let () = assert (stack_size ce = original_stack_size) in ce (** [add_constructor_arguments_to_memory args] realizes [args] on the memory * according to the ABI. This leaves the amount of memory on the stack. * Usually this function is called right after the constructor code is set up in the memory, * so the offset of the memory is not returned. * (This makes it easy for the zero-argument case) *) and add_constructor_arguments_to_memory le (packing : memoryPacking) ce (args : Syntax.typ exp list) = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH1 (Int 0)) in (* stack [0] *) let ce = List.fold_left (add_constructor_argument_to_memory le packing) ce args in let () = assert (original_stack_size + 1 = stack_size ce) in ce and produce_init_code_in_memory (le : LocationEnv.t) ce new_exp = let name = new_exp.new_head in let contract_id = try CodegenEnv.cid_lookup ce name with Not_found -> let () = Printf.eprintf "A contract of name %s is unknown.\n%!" name in raise Not_found in let ce = append_instruction ce (PUSH32 (ConstructorCodeSize contract_id)) in let ce = append_instruction ce (PUSH32 (ConstructorInRuntimeCodeOffset contract_id)) in (* stack: [codesize, codeoffset] *) let ce = copy_from_code_to_memory ce in (* stack: [memory_size, memory_offset] *) let ce = copy_whole_current_code_to_memory ce in (* stack: [memory_size, memory_offset, memory_second_size, memory_second_offset] *) (* I still need to add the constructor arguments *) let ce = add_constructor_arguments_to_memory le ABIPacking ce new_exp.new_args in (* stack: [memory_size, memory_offset, memory_second_size, memory_second_offset, memory_args_size] *) let ce = append_instruction ce SWAP1 in (* stack: [memory_size, memory_offset, memory_second_size, memory_args_size, memory_second_offset] *) let ce = append_instruction ce POP in (* stack: [memory_size, memory_offset, memory_second_size, memory_args_size] *) let ce = append_instruction ce ADD in (* stack: [memory_size, memory_offset, memory_second_args_size] *) let ce = append_instruction ce SWAP1 in (* stack: [memory_size, memory_second_args_size, memory_offset] *) let ce = append_instruction ce SWAP2 in (* stack: [memory_offset, memory_second_args_size, memory_size] *) let ce = append_instruction ce ADD in (* stack: [memory_offset, memory_total_size] *) let ce = append_instruction ce SWAP1 in (* stack: [memory_total_size, memory_offset] *) ce and codegen_function_call_exp (le : LocationEnv.t) ce alignment (function_call : Syntax.typ Syntax.function_call) (rettyp : Syntax.typ) = if function_call.call_head = "pre_ecdsarecover" then let () = assert (alignment = RightAligned) in codegen_ecdsarecover le ce function_call.call_args rettyp (* XXX: need to pass alignment *) else if function_call.call_head = "keccak256" then let () = assert (alignment = RightAligned) in codegen_keccak256 le ce function_call.call_args rettyp (* XXX: need to pass alignment *) else if function_call.call_head = "iszero" then codegen_iszero le ce alignment function_call.call_args rettyp else failwith "codegen_function_call_exp: unknown function head." and codegen_iszero le ce alignment args rettype = match args with | [arg] -> let () = assert (rettype = BoolType) in let ce = codegen_exp le ce alignment arg in let ce = append_instruction ce ISZERO in ce | _ -> failwith "codegen_iszero: seeing a wrong number of arguments" and codegen_keccak256 le ce args rettyp = let original_stack_size = stack_size ce in let ce = peek_next_memory_allocation ce in (* stack: [..., offset] *) let ce = add_constructor_arguments_to_memory le TightPacking ce args in (* stack: [..., offset, size] *) let ce = append_instruction ce SWAP1 in (* stack: [..., size, offset] *) let ce = append_instruction ce SHA3 in let () = assert(stack_size ce = original_stack_size + 1) in ce and codegen_ecdsarecover le ce args rettyp = match args with | [h; v; r; s] -> (* stack: [] *) let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH1 (Int 32)) in (* stack: [out size] *) let ce = append_instruction ce DUP1 in (* stack: [out size, out size] *) let ce = push_allocated_memory ce in (* stack: [out size, out address] *) let ce = append_instruction ce DUP2 in (* stack: [out size, out address, out size] *) let ce = append_instruction ce DUP2 in (* stack: [out size, out address, out size, out address] *) let ce = peek_next_memory_allocation ce in let ce = add_constructor_arguments_to_memory le ABIPacking ce args in (* stack: [out size, out address, out size, out address, memory_offset, memory_total_size] *) let ce = append_instruction ce SWAP1 in (* stack: [out size, out address, out size, out address, in size, in offset] *) let ce = append_instruction ce (PUSH1 (Int 0)) in (* stack: [out size, out address, out size, out address, in size, in offset, value] *) let () = assert (stack_size ce = original_stack_size + 7) in let ce = append_instruction ce (PUSH1 (Int 1)) in (* stack: [out size, out address, out size, out address, in size, in offset, value, to] *) let ce = append_instruction ce (PUSH4 (Int 10000)) in (* stack: [out size, out address, out size, out offset, in size, in offset, value, to, gas] *) let ce = append_instruction ce CALL in let () = assert (stack_size ce = original_stack_size + 3) in (* stack: [out size, out address, success?] *) let ce = throw_if_zero ce in let ce = append_instruction ce POP in (* stack: [out size, out address] *) let () = assert (stack_size ce = original_stack_size + 2) in let ce = append_instruction ce SWAP1 in (* stack: [out address, out size] *) let ce = append_instruction ce POP in (* we know it's 32 *) (* stack: [out address] *) let ce = append_instruction ce MLOAD in let () = assert (stack_size ce = original_stack_size + 1) in (* stack: [output] *) ce | _ -> failwith "pre_ecdsarecover has a wrong number of arguments" and codegen_new_exp (le : LocationEnv.t) ce (new_exp : Syntax.typ Syntax.new_exp) (contractname : string) = let original_stack_size = stack_size ce in (* assert that the reentrance info is throw *) let () = assert(is_throw_only new_exp.new_msg_info.message_reentrance_info) in (* set up the reentrance guard *) let ce = swap_entrance_pc_with_zero ce in (* stack : [entrance_pc_bkp] *) let ce = produce_init_code_in_memory le ce new_exp in (* stack : [entrance_pc_bkp, size, offset] *) let ce = (match new_exp.new_msg_info.message_value_info with | None -> append_instruction ce (PUSH1 (Int 0)) (* no value info means value of zero *) | Some e -> codegen_exp le ce RightAligned e) in (* stack : [entrance_pc_bkp, size, offset, value] *) let ce = append_instruction ce CREATE in (* stack : [entrance_pc_bkp, create_result] *) (* check the return value, if zero, throw *) let ce = throw_if_zero ce in (* stack : [entrance_pc_bkp, create_result] *) let ce = append_instruction ce SWAP1 in (* stack : [create_result, entrance_pc_bkp] *) (* remove the reentrance guard *) let ce = restore_entrance_pc ce in (* stack : [create_result] *) let () = assert (stack_size ce = original_stack_size + 1) in ce and generate_array_access_index le ce aa = let array = aa.array_access_array in let index = aa.array_access_index in let ce = codegen_exp le ce RightAligned index in let ce = codegen_exp le ce RightAligned array in let ce = keccak_cons le ce in ce and codegen_array_access (le : LocationEnv.t) ce (aa : Syntax.typ Syntax.array_access) = let ce = generate_array_access_index le ce aa in let ce = append_instruction ce SLOAD in ce (* if the stack top is zero, set up an array seed at aa, and replace the zero with the new seed *) and setup_array_seed_at_array_access le ce aa = let shortcut_label = Label.new_label () in (* stack: [result, result] *) let ce = append_instruction ce DUP1 in (* stack: [result, result] *) let ce = append_label ce shortcut_label in (* stack: [result, result, shortcut] *) let ce = append_instruction ce JUMPI in (* stack: [result] *) let ce = append_instruction ce POP in (* stack: [] *) let ce = generate_array_access_index le ce aa in (* stack: [storage_index] *) let ce = append_instruction ce (PUSH1 (Int 1)) in (* stack: [storage_index, 1] *) let ce = append_instruction ce SLOAD in (* stack: [storage_index, orig_seed] *) let ce = append_instruction ce DUP1 in (* stack: [storage_index, orig_seed, orig_seed] *) let ce = increase_top ce 1 in (* stack: [storage_index, orig_seed, orig_seed + 1] *) let ce = append_instruction ce (PUSH1 (PseudoImm.Int 1)) in (* stack: [storage_index, orig_seed, orig_seed + 1, 1] *) let ce = append_instruction ce SSTORE in (* stack: [storage_index, orig_seed] *) let ce = append_instruction ce DUP1 in (* stack: [storage_index, orig_seed, orig_seed] *) let ce = append_instruction ce SWAP2 in (* stack: [orig_seed, orig_seed, storage_index] *) let ce = append_instruction ce SSTORE in (* stack: [orig_seed] *) let ce = append_instruction ce (JUMPDEST shortcut_label) in (* stack: [result] *) ce (* if the stack top is zero, set up an array seed at aa, and replace the zero with the new seed *) and setup_array_seed_at_location le ce loc = let storage_idx = match loc with | Location.Storage str_range -> let () = assert (str_range.Location.storage_size = (Int 1)) in str_range.Location.storage_start | _ -> failwith "setup array seed at non-storage" in let shortcut_label = Label.new_label () in (* stack: [result, result] *) let ce = append_instruction ce DUP1 in (* stack: [result, result] *) let ce = append_instruction ce (PUSH32 (DestLabel shortcut_label)) in (* stack: [result, result, shortcut] *) let ce = append_instruction ce JUMPI in (* stack: [result] *) let ce = append_instruction ce POP in (* stack: [] *) let ce = append_instruction ce (PUSH32 storage_idx) in (* stack: [storage_index] *) let ce = append_instruction ce (PUSH1 (Int 1)) in (* stack: [storage_index, 1] *) let ce = append_instruction ce SLOAD in (* stack: [storage_index, orig_seed] *) let ce = append_instruction ce DUP1 in (* stack: [storage_index, orig_seed, orig_seed] *) let ce = increase_top ce 1 in (* stack: [storage_index, orig_seed, orig_seed + 1] *) let ce = append_instruction ce (PUSH1 (PseudoImm.Int 1)) in (* stack: [storage_index, orig_seed, orig_seed + 1, 1] *) let ce = append_instruction ce SSTORE in (* stack: [storage_index, orig_seed] *) let ce = append_instruction ce DUP1 in (* stack: [storage_index, orig_seed, orig_seed] *) let ce = append_instruction ce SWAP2 in (* stack: [orig_seed, orig_seed, storage_index] *) let ce = append_instruction ce SSTORE in (* stack: [orig_seed] *) let ce = append_instruction ce (JUMPDEST shortcut_label) in (* stack: [result] *) ce (* le is not updated here. It can be only updated in * a variable initialization *) and codegen_exp (le : LocationEnv.t) (ce : CodegenEnv.t) (alignment : alignment) ((e,t) : Syntax.typ Syntax.exp) : CodegenEnv.t = let ret = (match e,t with | AddressExp ((c, ContractInstanceType _)as inner), AddressType -> let ce = codegen_exp le ce alignment inner in (* c is a contract instance. * The concrete representation of a contact instance is * already the address *) ce | AddressExp _, _ -> failwith "codegen_exp: AddressExp of unexpected type" | ValueExp,Uint256Type -> let ce = CodegenEnv.append_instruction ce CALLVALUE in ce | ValueExp,_ -> failwith "ValueExp of strange type" | SenderExp,AddressType -> let ce = CodegenEnv.append_instruction ce CALLER in let ce = align_address ce alignment in ce | SenderExp,_ -> failwith "codegen_exp: SenderExp of strange type" | ArrayAccessExp aa, typ -> let ce = codegen_array_access le ce (read_array_access aa) in let () = assert (alignment = RightAligned) in begin match typ with | MappingType _ -> setup_array_seed_at_array_access le ce (read_array_access aa) | _ -> ce end | ThisExp,_ -> let ce = CodegenEnv.append_instruction ce ADDRESS in let ce = align_address ce alignment in ce | IdentifierExp id, typ -> begin match LocationEnv.lookup le id with (** if things are just DUP'ed, location env should not be * updated. If they are SLOADED, the location env should be * updated. *) | Some location -> let (le, ce) = copy_to_stack_top le ce alignment typ location in begin match typ with | MappingType _ -> setup_array_seed_at_location le ce location | _ -> ce end | None -> failwith ("codegen_exp: identifier's location not found: "^id) end | FalseExp,BoolType -> let ce = CodegenEnv.append_instruction ce (Evm.PUSH1 (Big WrapBn.zero_big_int)) in let () = assert (alignment = RightAligned) in ce | FalseExp, _ -> failwith "codegen_exp: FalseExp of unexpected type" | TrueExp,BoolType -> let ce = append_instruction ce (PUSH1 (Big WrapBn.unit_big_int)) in let () = assert (alignment = RightAligned) in ce | TrueExp, _ -> failwith "codegen_exp: TrueExp of unexpected type" | DecLit256Exp d, Uint256Type -> let ce = append_instruction ce (PUSH32 (Big d)) in let () = assert (alignment = RightAligned) in ce | DecLit256Exp d, _ -> failwith ("codegen_exp: DecLit256Exp of unexpected type: "^(WrapBn.string_of_big_int d)) | DecLit8Exp d, Uint8Type -> let ce = append_instruction ce (PUSH1 (Big d)) in let () = assert (alignment = RightAligned) in ce | DecLit8Exp d, _ -> failwith ("codegen_exp: DecLit8Exp of unexpected type: "^(WrapBn.string_of_big_int d)) | LandExp (l, r), BoolType -> let shortcut_label = Label.new_label () in let () = assert (alignment = RightAligned) in let ce = codegen_exp le ce RightAligned l in (* stack: [..., l] *) let ce = append_instruction ce DUP1 in (* stack: [..., l, l] *) let ce = append_instruction ce ISZERO in (* stack: [..., l, !l] *) let ce = append_label ce shortcut_label in (* stack: [..., l, !l, shortcut] *) let ce = append_instruction ce JUMPI in (* stack: [..., l] *) let ce = append_instruction ce POP in (* stack: [...] *) let ce = codegen_exp le ce RightAligned r in (* stack: [..., r] *) let ce = append_instruction ce (JUMPDEST shortcut_label) in let ce = append_instruction ce ISZERO in let ce = append_instruction ce ISZERO in ce | LandExp (_, _), _ -> failwith "codegen_exp: LandExp of unexpected type" | NotExp sub, BoolType -> let ce = codegen_exp le ce alignment sub in let ce = append_instruction ce ISZERO in let ce = align_boolean ce alignment in ce | NotExp sub, _ -> failwith "codegen_exp: NotExp of unexpected type" | NowExp,Uint256Type -> append_instruction ce TIMESTAMP | NowExp,_ -> failwith "codegen_exp: NowExp of unexpected type" | NeqExp (l, r), BoolType -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in (* l later because it should come at the top *) let ce = append_instruction ce EQ in let ce = append_instruction ce ISZERO in let ce = align_boolean ce alignment in ce | NeqExp _, _ -> failwith "codegen_exp: NeqExp of unexpected type" | LtExp (l, r), BoolType -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce LT in let ce = align_boolean ce alignment in ce | LtExp _, _ -> failwith "codegen_exp: LtExp of unexpected type" | PlusExp (l, r), Uint256Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce ADD in ce | PlusExp (l, r), Uint8Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce ADD in ce | PlusExp (l, r), _ -> failwith "codegen_exp PlusExp of unexpected type" | MinusExp (l, r), Uint256Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce SUB in ce | MinusExp (l, r), Uint8Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce SUB in ce | MinusExp (l, r), _ -> failwith "codegen_exp MinusExp of unexpected type" | MultExp (l, r), Uint256Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce MUL in ce | MultExp (l, r), Uint8Type -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce MUL in ce | MultExp (l, r), _ -> failwith "codegen_exp: MultExp of unexpected type" | GtExp (l, r), BoolType -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce GT in let ce = align_boolean ce alignment in (* XXX there should be some type system making sure this line exists *) ce | GtExp _, _ -> failwith "codegen_exp GtExp of unexpected type" | BalanceExp inner, Uint256Type -> let ce = codegen_exp le ce RightAligned inner in let ce = append_instruction ce BALANCE in ce | BalanceExp inner, _ -> failwith "codegen_exp: BalanceExp of unexpected type" | EqualityExp (l, r), BoolType -> let ce = codegen_exp le ce RightAligned r in let ce = codegen_exp le ce RightAligned l in let ce = append_instruction ce EQ in let ce = align_boolean ce alignment in ce | EqualityExp _, _ -> failwith "codegen_exp EqualityExp of unexpected type" | SendExp s, _ -> let () = assert (alignment = RightAligned) in codegen_send_exp le ce s | NewExp new_e, ContractInstanceType ctyp -> let () = assert (alignment = RightAligned) in codegen_new_exp le ce new_e ctyp | NewExp new_e, _ -> failwith "exp code gen for new expression with unexpected type" | FunctionCallExp function_call, rettyp -> codegen_function_call_exp le ce alignment function_call rettyp | ParenthExp _, _ -> failwith "ParenthExp not expected." | SingleDereferenceExp (reference, ref_typ), value_typ -> let () = assert (ref_typ = ReferenceType [value_typ]) in let size = Syntax.size_of_typ value_typ in let () = assert (size <= 32) in (* assuming word-size *) let ce = codegen_exp le ce RightAligned (reference, ref_typ) in (* pushes the pointer *) let ce = append_instruction ce MLOAD in let () = assert (alignment = RightAligned) in ce | TupleDereferenceExp _, _ -> failwith "code generation for TupleDereferenceExp should not happen. Instead, try to decompose it into several assignments." ) in let () = assert (stack_size ret = stack_size ce + 1) in ret (** [prepare_argument ce arg] places an argument in the memory, and increments the stack top position by the size of the argument. *) and prepare_argument le ce arg = (* stack: (..., accum) *) let original_stack_size = stack_size ce in let size = Syntax.size_of_typ (snd arg) in let () = assert (size = 32) in let ce = append_instruction ce (PUSH1 (Int size)) in (* stack: (..., accum, size) *) let ce = codegen_exp le ce RightAligned arg in (* stack: (..., accum, size, val) *) let ce = append_instruction ce DUP2 in (* stack: (..., accum, size, val, size) *) let ce = push_allocated_memory ce in (* stack: (..., accum, size, val, offset) *) let ce = append_instruction ce MSTORE in (* stack: (..., accum, size) *) let ce = append_instruction ce ADD in (* stack: (..., new_accum) *) let () = assert (stack_size ce = original_stack_size) in ce (** [prepare_arguments] prepares arguments in the memory. * This leaves (..., args size) on the stack. * Since this is called always immediately after allocating memory for the signature, * the offset of the memory is not necessary. * Also, when there are zero amount of memory desired, it's easy to just return zero. *) and prepare_arguments le ce args = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = List.fold_left (prepare_argument le) ce args in let () = assert (stack_size ce = original_stack_size + 1) in ce (** [prepare_input_in_memory] prepares the input for CALL instruction in the memory. * That leaves "..., in size, in offset" (top) on the stack. *) and prepare_input_in_memory le ce s usual_header : CodegenEnv.t = let original_stack_size = stack_size ce in let ce = prepare_function_signature ce usual_header in (* stack : [signature size, signature offset] *) let args = s.send_args in let ce = prepare_arguments le ce args in (* this should leave only one number on the stack!! *) (* stack : [signature size, signature offset, args size] *) let ce = append_instruction ce SWAP1 in (* stack : [signature size, args size, signature offset] *) let ce = append_instruction ce SWAP2 in (* stack : [signature offset, args size, signature size] *) let ce = append_instruction ce ADD in (* stack : [signature offset, total size] *) let ce = append_instruction ce SWAP1 in (* stack : [total size, signature offset] *) let () = assert (stack_size ce = original_stack_size + 2) in ce (** [obtain_return_values_from_memory] assumes stack (..., out size, out offset), and copies the outputs onto the stack. The first comes top-most. *) (* XXX currently supports one-word output only *) and obtain_return_values_from_memory ce = (* stack: out size, out offset *) let ce = append_instruction ce DUP2 in (* stack: out size, out offset, out size *) let ce = append_instruction ce (PUSH1 (Int 32)) in (* stack: out size, out offset, out size, 32 *) let ce = append_instruction ce EQ in (* stack: out size, out offset, out size = 32 *) let ce = append_instruction ce ISZERO in (* stack: out size, out offset, out size != 32 *) let ce = append_instruction ce (PUSH1 (Int 0)) in (* stack: out size, out offset, out size != 32, 0 *) let ce = append_instruction ce JUMPI in (* stack: out size, out offset *) let ce = append_instruction ce MLOAD in (* stack: out size, out *) let ce = append_instruction ce SWAP1 in (* stack: out, out size *) let ce = append_instruction ce POP in (* stack: out *) ce and codegen_send_exp le ce (s : Syntax.typ Syntax.send_exp) = let original_stack_size = stack_size ce in let head_contract = s.send_head_contract in match snd head_contract with | ContractInstanceType contract_name -> let callee_contract_id = try CodegenEnv.cid_lookup ce contract_name with Not_found -> let () = Printf.eprintf "A contract of name %s is unknown.\n%!" contract_name in raise Not_found in let callee_contract : Syntax.typ Syntax.contract = CodegenEnv.contract_lookup ce callee_contract_id in let contract_lookup_by_name (name : string) : Syntax.typ Syntax.contract = let contract_id = begin try CodegenEnv.cid_lookup ce name with Not_found -> let () = Printf.eprintf "A contract of name %s is unknown.\n%!" contract_name in raise Not_found end in CodegenEnv.contract_lookup ce contract_id in begin match s.send_head_method with | None -> failwith "could not find the method name" | Some method_name -> let usual_header : usual_case_header = Syntax.lookup_usual_case_header callee_contract method_name contract_lookup_by_name in let () = assert(is_throw_only s.send_msg_info.message_reentrance_info) in let ce = swap_entrance_pc_with_zero ce in (* stack : [entrance_pc_bkp] *) let return_typ = usual_header.case_return_typ in let return_size = Syntax.size_of_typs return_typ in (* stack : [entrance_bkp] *) let ce = append_instruction ce (PUSH1 (Int return_size)) in (* stack : [entrance_bkp, out size] *) let ce = append_instruction ce DUP1 in (* stack : [entrance_bkp, out size, out size] *) let () = assert (stack_size ce = original_stack_size + 3) in let ce = push_allocated_memory ce in (* stack : [entrance_bkp, out size, out offset] *) let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, out size, out offset, out size] *) let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, out size, out offset, out size, out offset] *) let ce = prepare_input_in_memory le ce s usual_header in (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset] *) let ce = (match s.send_msg_info.message_value_info with | None -> append_instruction ce (PUSH1 (Int 0)) (* no value info means value of zero *) | Some e -> codegen_exp le ce RightAligned e) in (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset, value] *) let ce = codegen_exp le ce RightAligned s.send_head_contract in let ce = append_instruction ce (PUSH4 (Int 3000)) in let ce = append_instruction ce GAS in let ce = append_instruction ce SUB in (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset, value, to, gas] *) let ce = append_instruction ce CALL in (* stack : [entrance_bkp, out size, out offset, success] *) let () = assert (stack_size ce = original_stack_size + 4) in let ce = append_instruction ce ISZERO in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce JUMPI in (* stack : [entrance_bkp, out size, out offset] *) let () = assert (stack_size ce = original_stack_size + 3) in let ce = append_instruction ce SWAP2 in (* stack : [out offset, out size entrance_bkp] *) let ce = restore_entrance_pc ce in (* stack : [out offset, out size] *) let ce = append_instruction ce SWAP1 in (* stack : [out size, out offset] *) let ce = obtain_return_values_from_memory ce in (* stack : [outputs] *) ce end | AddressType -> let () = assert(is_throw_only s.send_msg_info.message_reentrance_info) in let ce = swap_entrance_pc_with_zero ce in (* stack : [entrance_pc_bkp] *) let return_size = 0 in (* stack : [entrance_bkp] *) let ce = append_instruction ce (PUSH1 (Int return_size)) in (* stack : [entrance_bkp, 0] *) let ce = append_instruction ce DUP1 in (* stack : [entrance_bkp, 0, 0] *) let () = assert (stack_size ce = original_stack_size + 3) in let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, 0, 0, 0] *) let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, 0, 0, 0, 0] *) let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, 0, 0, 0, 0, 0] *) let ce = append_instruction ce DUP2 in (* stack : [entrance_bkp, 0, 0, 0, 0, 0, 0] *) (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset] *) let ce = (match s.send_msg_info.message_value_info with | None -> append_instruction ce (PUSH1 (Int 0)) (* no value info means value of zero *) | Some e -> codegen_exp le ce RightAligned e) in (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset, value] *) let ce = codegen_exp le ce RightAligned s.send_head_contract in let ce = append_instruction ce (PUSH4 (Int 3000)) in let ce = append_instruction ce GAS in let ce = append_instruction ce SUB in (* stack : [entrance_bkp, out size, out offset, out size, out offset, in size, in offset, value, to, gas] *) let ce = append_instruction ce CALL in (* stack : [entrance_bkp, out size, out offset, success] *) let () = assert (stack_size ce = original_stack_size + 4) in let ce = append_instruction ce ISZERO in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce JUMPI in (* stack : [entrance_bkp, out size, out offset] *) let () = assert (stack_size ce = original_stack_size + 3) in let ce = append_instruction ce SWAP2 in (* stack : [out offset, out size entrance_bkp] *) let ce = restore_entrance_pc ce in (* stack : [0, 0] *) let ce = append_instruction ce POP in (* XXX: Some optimizations possible. *) (* stack : [0] *) ce | VoidType -> failwith "send expression with VoidType?" | Uint256Type -> failwith "send expression with Uint256Type?" | Uint8Type -> failwith "send expression with Uint8Type?" | _ -> failwith "send expression with unknown type" let codegen_sentence (orig : CodegenEnv.t) (s : Syntax.typ Syntax.sentence) (* is this enough? also add sentence Id's around? * I think this is enough. *) : CodegenEnv.t = failwith "codegen_sentence" let move_info_around (assumption : CodegenEnv.t) (goal : LocationEnv.t) : CodegenEnv.t = failwith "move_info_around" let codegen_bytecode (src : Syntax.typ Syntax.contract) : PseudoImm.pseudo_imm Evm.program = failwith "codegen_bytecode" (** [initialize_memory_allocator] initializes memory position 64 as 96 *) let initialize_memory_allocator (ce : CodegenEnv.t) = let ce = append_instruction ce (PUSH1 (Int 96)) in let ce = append_instruction ce (PUSH1 (Int 64)) in let ce = append_instruction ce MSTORE in ce (** [copy_arguments_from_code_to_memory] * copies constructor arguments at the end of the * bytecode into the memory. The number of bytes is * decided using the contract interface. * The memory usage counter at byte [0x40] is increased accordingly. * After this, the stack contains the size and the beginning of the memory * piece that contains the arguments. * Output [rest of the stack, mem_size, mem_begin]. *) let copy_arguments_from_code_to_memory (le : LocationEnv.t) (ce : CodegenEnv.t) (contract : Syntax.typ Syntax.contract) : (CodegenEnv.t) = let total_size = Ethereum.total_size_of_interface_args (List.map snd (Ethereum.constructor_arguments contract)) in let original_stack_size = stack_size ce in (* [] *) let ce = append_instruction ce (PUSH32 (Int total_size)) in (* [total_size] *) let ce = append_instruction ce DUP1 in (* [total_size, total_size] *) let ce = push_allocated_memory ce in (* [total_size, memory_start] *) let ce = append_instruction ce DUP2 in (* [total_size, memory_start, total_size] *) let ce = append_instruction ce DUP1 in (* [total_size, memory_start, total_size, total_size] *) let ce = append_instruction ce CODESIZE in (* [total_size, memory_start, total_size, total_size, code size] *) let ce = append_instruction ce SUB in (* [total_size, memory_start, total_size, code_begin] *) let ce = append_instruction ce DUP3 in (* [total size, memory_start, total_size, code_begin, memory_start *) let ce = append_instruction ce CODECOPY in (* [total size, memory_start] *) let () = assert (original_stack_size + 2 = stack_size ce) in ce (** * [set_contract_pc ce id] puts the program counter for the contract specified by [id] in the storage at index [StorageProgramCounterIndex] *) let set_contract_pc ce (id : Assoc.contract_id) = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH32 (ContractOffsetInRuntimeCode id)) in let ce = append_instruction ce (PUSH32 StorageProgramCounterIndex) in let ce = append_instruction ce SSTORE in let () = assert (stack_size ce = original_stack_size) in ce (** * [get_contract_pc ce] pushes the value at [StorageProgramCounterIndex] in storage. *) let get_contract_pc ce = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH32 StorageProgramCounterIndex) in let ce = append_instruction ce SLOAD in let () = assert (stack_size ce = original_stack_size + 1) in ce (** * [bulk_store_from_memory ce] * adds instructions to ce after which some memory contents are copied * to the storage. * Precondition: the stack has [..., size, memory_src_start, storage_target_start] * Postcondition: the stack has [...] *) let bulk_sstore_from_memory ce = let original_stack_size = stack_size ce in (* TODO: check that size is a multiple of 32 *) let jump_label_continue = Label.new_label () in let jump_label_exit = Label.new_label () in let ce = append_instruction ce (JUMPDEST jump_label_continue) in (* stack [..., size, memory_src_start, storage_target_start] *) let ce = append_instruction ce DUP3 in (* stack [..., size, memory_src_start, storage_target_start, size] *) let ce = append_instruction ce ISZERO in (* stack [..., size, memory_src_start, storage_target_start, size is zero] *) let ce = append_label ce jump_label_exit in (* stack [..., size, memory_src_start, storage_target_start, size is zero, jump_label_exit] *) let () = assert (stack_size ce = original_stack_size + 2) in let ce = append_instruction ce JUMPI in (* stack [..., size, memory_src_start, storage_target_start] *) let ce = append_instruction ce DUP2 in (* stack [..., size, memory_src_start, storage_target_start, memory_src_start] *) let ce = append_instruction ce MLOAD in (* stack [..., size, memory_src_start, storage_target_start, stored] *) let ce = append_instruction ce DUP2 in (* stack [..., size, memory_src_start, storage_target_start, stored, storage_target_start] *) let ce = append_instruction ce SSTORE in (* stack [..., size, memory_src_start, storage_target_start] *) (* decrease size *) let ce = append_instruction ce (PUSH32 (Int 32)) in (* stack [..., size, memory_src_start, storage_target_start, 32] *) let ce = append_instruction ce SWAP1 in (* stack [..., size, memory_src_start, 32, storage_target_start] *) let ce = append_instruction ce SWAP3 in (* stack [..., storage_target_start, memory_src_start, 32, size] *) let ce = append_instruction ce SUB in (* stack [..., storage_target_start, memory_src_start, new_size] *) let ce = append_instruction ce SWAP2 in (* stack [..., new_size, memory_src_start, storage_target_start] *) let ce = increase_top ce 1 in (* 1 word is 32 bytes. *) (* stack [..., new_size, memory_src_start, new_storage_target_start] *) let ce = append_instruction ce SWAP1 in (* stack [..., new_size, new_storage_target_start, memory_src_start] *) (* increase memory_src_start *) let ce = increase_top ce 32 in (* stack [..., new_size, new_storage_target_start, new_memory_src_start] *) let ce = append_instruction ce SWAP1 in (* stack [..., new_size, new_memory_src_start, new_storage_target_start] *) let () = assert (stack_size ce = original_stack_size) in (** add create a combinatino of jump and reset_stack_size *) let ce = append_label ce jump_label_continue in let ce = append_instruction ce JUMP in (* stack [..., new_size, new_memory_src_start, new_storage_target_start] *) let ce = set_stack_size ce (original_stack_size) in let ce = append_instruction ce (JUMPDEST jump_label_exit) in (* stack [..., size, memory_src_start, storage_target_start] *) let ce = append_instruction ce POP in let ce = append_instruction ce POP in let ce = append_instruction ce POP in let () = assert (stack_size ce = original_stack_size - 3) in (* stack [...] *) ce (** [copy_arguments_from_memory_to_storage le ce] * adds instructions to ce such that the constructor arguments * stored in the memory are copied to the storage. * Precondition: the stack has [..., total, memory_start] * Final storage has the arguments in [ConstructorArgumentBegin...ConstructorArgumentBegin + ConstructorArgumentLength] * The final stack has [...] in the precondition. *) let copy_arguments_from_memory_to_storage le ce (contract_id : Assoc.contract_id) = let ce = append_instruction ce (PUSH32 (InitDataSize contract_id)) in let ce = append_instruction ce CODESIZE in let ce = append_instruction ce EQ in let ce = append_instruction ce ISZERO in let ce = append_instruction ce (PUSH1 (Int 2)) in let ce = append_instruction ce JUMPI in let ce = append_instruction ce (PUSH32 (StorageConstructorArgumentsBegin contract_id)) in (* stack, [..., size, memory_start, destination_storage_start] *) bulk_sstore_from_memory ce (** [copy_runtime_code_to_memory ce contracts contract_id] * adds instructions to [ce] so that in the final * state the memory contains the runtime code * for all contracts that are reachable from [contract_id] in the * list [contracts] in the * addresses [code_start, code_start + code_size). * This adds two elements to the stack, resulting in * [..., code_length, code_start) *) let copy_runtime_code_to_memory ce contracts contract_id = let original_stack_size = stack_size ce in (* stack: [...] *) let ce = append_instruction ce (PUSH32 (RuntimeCodeSize)) in (* stack: [run_code_size] *) let ce = append_instruction ce DUP1 in (* stack: [run_code_size, run_code_size] *) let ce = push_allocated_memory ce in (* stack: [run_code_size, run_code_address] *) let ce = append_instruction ce DUP2 in (* stack: [run_code_size, run_code_address, run_code_size] *) let ce = append_instruction ce (PUSH32 (RuntimeCodeOffset contract_id)) in (* stack: [run_code_size, run_code_address, run_code_size, RuntimeCodeOffset] *) let ce = append_instruction ce DUP3 in (* stack: [run_code_size, run_code_address, run_code_size, run_code_in_code, run_code_address] *) let ce = append_instruction ce CODECOPY in (* stack: [run_code_size, run_code_address] *) let () = assert (stack_size ce = original_stack_size + 2) in ce let cid_lookup_in_assoc (contracts : Syntax.typ Syntax.contract Assoc.contract_id_assoc) (name : string) : Assoc.contract_id = Assoc.lookup_id (fun c -> c.contract_name = name) contracts let setup_seed (le, ce) (loc : Storage.storage_location) = let jump_label_skip = Label.new_label () in let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH4 (PseudoImm.Int loc)) in (* stack: [seed] *) let ce = append_label ce jump_label_skip in let ce = append_instruction ce JUMPI in let ce = append_instruction ce (PUSH1 (PseudoImm.Int 1)) in (* stack: [1] *) let ce = append_instruction ce SLOAD in (* stack: [orig_seed] *) let ce = append_instruction ce DUP1 in (* stack: [orig_seed, orig_seed] *) let ce = append_instruction ce (PUSH4 (PseudoImm.Int loc)) in (* stack: [orig_seed, orig_seed, loc] *) let ce = append_instruction ce SSTORE in (* stack: [orig_seed] *) let ce = increase_top ce 1 in (* stack: [orig_seed + 1] *) let ce = append_instruction ce (PUSH1 (PseudoImm.Int 1)) in (* stack: [orig_seed + 1, 1] *) let ce = append_instruction ce SSTORE in let ce = append_instruction ce (JUMPDEST jump_label_skip) in (* stack: [] *) let () = assert (stack_size ce = original_stack_size) in (le, ce) let setup_array_seed_counter_to_one_if_not_initialized ce = let original_stack_size = stack_size ce in let jump_label_skip = Label.new_label () in let ce = append_instruction ce (PUSH1 (Int 1)) in let ce = append_instruction ce SLOAD in let ce = append_label ce jump_label_skip in let ce = append_instruction ce JUMPI in (* the case where it has to be changed *) let ce = append_instruction ce (PUSH1 (Int 1)) in let ce = append_instruction ce DUP1 in let ce = append_instruction ce SSTORE in let ce = append_instruction ce (JUMPDEST jump_label_skip) in let () = assert (stack_size ce = original_stack_size) in ce let setup_array_seeds le ce (contract: Syntax.typ Syntax.contract) : CodegenEnv.t = let ce = setup_array_seed_counter_to_one_if_not_initialized ce in let array_locations = LayoutInfo.array_locations contract in let (_, ce) = List.fold_left setup_seed (le, ce) array_locations in ce let codegen_constructor_bytecode ((contracts : Syntax.typ Syntax.contract Assoc.contract_id_assoc), (contract_id : Assoc.contract_id)) : (CodegenEnv.t (* containing the program *) ) = let le = LocationEnv.constructor_initial_env contract_id (Assoc.choose_contract contract_id contracts) in let ce = CodegenEnv.empty_env (cid_lookup_in_assoc contracts) contracts in let ce = initialize_memory_allocator ce in (* implement some kind of fold function over the argument list * each step generates new (le,ce) *) let ce = copy_arguments_from_code_to_memory le ce (Assoc.choose_contract contract_id contracts) in (* stack: [arg_mem_size, arg_mem_begin] *) let (ce: CodegenEnv.t) = copy_arguments_from_memory_to_storage le ce contract_id in (* stack: [] *) (* set up array seeds *) let (ce :CodegenEnv.t) = setup_array_seeds le ce (Assoc.choose_contract contract_id contracts) in let ce = set_contract_pc ce contract_id in (* stack: [] *) let ce = copy_runtime_code_to_memory ce contracts contract_id in (* stack: [code_length, code_start_on_memory] *) let ce = CodegenEnv.append_instruction ce RETURN in ce type constructor_compiled = { constructor_codegen_env : CodegenEnv.t ; constructor_interface : Contract.contract_interface ; constructor_contract : Syntax.typ Syntax.contract } type runtime_compiled = { runtime_codegen_env : CodegenEnv.t ; runtime_contract_offsets : int Assoc.contract_id_assoc (* what form should the constructor code be encoded? 1. pseudo program. easy 2. pseudo codegen_env. maybe uniform *) } let empty_runtime_compiled cid_lookup layouts = { runtime_codegen_env = (CodegenEnv.empty_env cid_lookup layouts) ; runtime_contract_offsets = [] } let compile_constructor ((lst, cid) : (Syntax.typ Syntax.contract Assoc.contract_id_assoc * Assoc.contract_id)) : constructor_compiled = { constructor_codegen_env = codegen_constructor_bytecode (lst, cid) ; constructor_interface = Contract.contract_interface_of (List.assoc cid lst) ; constructor_contract = List.assoc cid lst } let compile_constructors (contracts : Syntax.typ Syntax.contract Assoc.contract_id_assoc) : constructor_compiled Assoc.contract_id_assoc = Assoc.pair_map (fun cid _ -> compile_constructor (contracts, cid)) contracts let initial_runtime_compiled (cid_lookup : string -> Assoc.contract_id) layouts : runtime_compiled = let ce = CodegenEnv.empty_env cid_lookup layouts in let ce = get_contract_pc ce in let ce = append_instruction ce JUMP in { runtime_codegen_env = ce ; runtime_contract_offsets = [] } let push_destination_for (ce : CodegenEnv.t) (cid : Assoc.contract_id) (case_signature : case_header) = append_instruction ce (PUSH32 (CaseOffsetInRuntimeCode (cid, case_signature))) let add_dispatcher_for_a_usual_case le ce contract_id case_signature = let original_stack_size = stack_size ce in let ce = append_instruction ce DUP1 in let ce = push_signature_code ce case_signature in let ce = append_instruction ce EQ in let ce = push_destination_for ce contract_id (UsualCaseHeader case_signature) in let ce = append_instruction ce JUMPI in let () = assert (stack_size ce = original_stack_size) in ce let add_dispatcher_for_default_case le ce contract_id = let original_stack_size = stack_size ce in let ce = push_destination_for ce contract_id DefaultCaseHeader in let ce = append_instruction ce JUMP in let () = assert (stack_size ce = original_stack_size) in ce let push_word_from_input_data_at_byte ce b = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH32 b) in let ce = append_instruction ce CALLDATALOAD in let () = assert (stack_size ce = original_stack_size + 1) in ce let stack_top_shift_right ce amount = let original_stack_size = stack_size ce in let ce = append_instruction ce (PUSH1 (Int amount)) in let ce = append_instruction ce (PUSH1 (Int 2)) in let ce = append_instruction ce EXP in let ce = append_instruction ce SWAP1 in let ce = append_instruction ce DIV in let () = assert (stack_size ce = original_stack_size) in ce let add_throw ce = (* Just using the same method as solc. *) let ce = append_instruction ce (PUSH1 (Int 2)) in let ce = append_instruction ce JUMP in ce let add_dispatcher le ce contract_id contract = let original_stack_size = stack_size ce in (* load the first four bytes of the input data *) let ce = push_word_from_input_data_at_byte ce (Int 0) in let ce = stack_top_shift_right ce Ethereum.(word_bits - signature_bits) in let () = assert (stack_size ce = original_stack_size + 1) in let case_signatures = List.map (fun x -> x.Syntax.case_header) contract.contract_cases in let usual_case_headers = WrapList.filter_map (fun h -> match h with DefaultCaseHeader -> None | UsualCaseHeader u -> Some u ) case_signatures in let ce = List.fold_left (fun ce case_signature -> add_dispatcher_for_a_usual_case le ce contract_id case_signature) ce usual_case_headers in let ce = append_instruction ce POP in (* the signature in input is not necessary anymore *) let ce = if List.exists (fun h -> match h with DefaultCaseHeader -> true | _ -> false) case_signatures then add_dispatcher_for_default_case le ce contract_id else add_throw ce in (le, ce) let add_case_destination ce (cid : Assoc.contract_id) (h : Syntax.case_header) = let new_label = Label.new_label () in let ce = append_instruction ce (JUMPDEST new_label) in let () = EntrypointDatabase.(register_entrypoint (Case (cid, h)) new_label) in ce (** [prepare_words_on_stack le ce [arg0 arg1]] evaluates * [arg1] and then [arg0] and puts them onto the stack. * [arg0] will be the topmost element of the stack. *) let prepare_words_on_stack le ce (args : typ exp list) = (le, List.fold_right (fun arg ce' -> codegen_exp le ce' RightAligned arg) args ce) let store_word_into_storage_location (le, ce) (arg_location : Storage.storage_location) = let ce = append_instruction ce (PUSH32 (PseudoImm.Int arg_location)) in let ce = append_instruction ce SSTORE in (le, ce) (** [store_words_into_storage_locations le ce arg_locations] moves the topmost stack element to the * location indicated by [arg_locations] and the next element to the next location and so on. * The stack elements will disappear. *) let store_words_into_storage_locations le ce arg_locations = List.fold_left store_word_into_storage_location (le, ce) arg_locations let set_contract_arguments le ce offset cid (args : typ exp list) = let contract = try contract_lookup ce cid with e -> let () = Printf.eprintf "set_contract_arguments: looking up %d\n" cid in raise e in let arg_locations : Storage.storage_location list = LayoutInfo.arg_locations offset contract in let () = assert (List.length arg_locations = List.length args) in let (le, ce) = prepare_words_on_stack le ce args in let (le, ce) = store_words_into_storage_locations le ce arg_locations in (* TODO * In a special case where no movements are necessary, we can then skip these arguments. *) (le, ce) let set_continuation_to_function_call le ce layout (fcall, typ_exp) = let head : string = fcall.call_head in let args : typ exp list = fcall.call_args in let cid = try cid_lookup ce head with Not_found -> let () = Printf.eprintf "contract of name %s not found\n%!" head in raise Not_found in let ce = set_contract_pc ce cid in let offset = layout.LayoutInfo.storage_constructor_arguments_begin cid in let (le, ce) = try set_contract_arguments le ce offset cid args with e -> let () = Printf.eprintf "name of contract: %s\n" head in let () = Printf.eprintf "set_continuation_to_function_call cid: %d\n" cid in raise e in (le, ce) (* * set_continuation sets the storage contents. * So that the next message call would start from the continuation. *) let set_continuation le ce (layout : LayoutInfo.layout_info) (cont_exp, typ_exp) = let original_stack_size = stack_size ce in let (le, ce) = match cont_exp with | FunctionCallExp fcall -> set_continuation_to_function_call le ce layout (fcall, typ_exp) | _ -> failwith "strange_continuation" in let () = assert (stack_size ce = original_stack_size) in (le, ce) (* * Before this, the stack contains * ..., value (depends on typ). * The value would be stored in memory * After this, the stack contains * ..., size_in_bytes, offset_in_memory *) let move_stack_top_to_memory typ le ce = let () = assert (size_of_typ typ <= 32) in (* ..., value *) let ce = append_instruction ce (PUSH1 (PseudoImm.Int 32)) in (* ..., value, 32 *) let ce = append_instruction ce DUP1 in (* ..., value, 32, 32 *) let ce = push_allocated_memory ce in (* ..., value, 32, addr *) let ce = append_instruction ce SWAP2 in (* ..., addr, 32, value *) let ce = append_instruction ce DUP3 in (* ..., addr, 32, value, addr *) let ce = append_instruction ce MSTORE in (* ..., addr, 32 *) let ce = append_instruction ce SWAP1 in (* ..., 32, addr *) ce (* * after this, the stack contains * ..., size, offset_in_memory *) let place_exp_in_memory le ce packing ((e, typ) : typ exp) = let original_stack_size = stack_size ce in let alignment = match packing with | ABIPacking -> RightAligned | TightPacking -> LeftAligned in let ce = codegen_exp le ce alignment (e, typ) in let () = assert (stack_size ce = 1 + original_stack_size) in (* the stack layout depends on typ *) let ce = move_stack_top_to_memory typ le ce in let () = assert (stack_size ce = 2 + original_stack_size) in le, ce (* * When called on [a, b, c], a shoud occupy the smallest address, and c should occupy the largest address. * after this, the stack contains * ..., size, offset_in_memory *) let rec place_exps_in_memory le ce packing (exps : typ exp list) = match exps with | [] -> let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce (PUSH1 (Int 0)) in le, ce | exp :: rest -> let le, ce = place_exp_in_memory le ce packing exp in (* stack : [size, offset] *) let ce = append_instruction ce SWAP1 in (* stack : [offset, size] *) let le, ce = place_exps_in_memory le ce packing rest in (* this recursion is a bit awkward *) (* stack : [offset, size, size', offset] *) let ce = append_instruction ce POP in (* stack : [offset, size, size'] *) let ce = append_instruction ce ADD in (* stack : [offset, size_sum] *) let ce = append_instruction ce SWAP1 in (* stack : [size_sum, offset] *) le, ce (* * return_mem_content assumes the stack left after place_exp_in_memory * ..., size, offset_in_memory *) let return_mem_content le ce = append_instruction ce RETURN let add_return le ce (layout : LayoutInfo.layout_info) ret = let original_stack_size = stack_size ce in let e = ret.return_exp in let c = ret.return_cont in let (le, ce) = set_continuation le ce layout c in let ce = match e with | Some e -> let (le, ce) = place_exp_in_memory le ce ABIPacking e in return_mem_content le ce | None -> append_instruction ce STOP in let () = assert (stack_size ce = original_stack_size) in (le, ce) let put_stacktop_into_array_access le ce layout (aa : Syntax.typ Syntax.array_access) = let array = aa.Syntax.array_access_array in let index = aa.Syntax.array_access_index in let ce = codegen_exp le ce RightAligned index in (* stack : [value, index] *) let ce = codegen_exp le ce RightAligned array in (* stack : [value, index, array_seed] *) let ce = keccak_cons le ce in (* stack : [value, kec(array_seed ^ index)] *) let ce = append_instruction ce SSTORE in ce let put_stacktop_into_lexp le ce layout l = let original_stack_size = stack_size ce in let ce = match l with | ArrayAccessLExp aa -> put_stacktop_into_array_access le ce layout aa in let () = assert (original_stack_size = stack_size ce + 1) in ce let add_assignment le ce layout l r = let original_stack_size = stack_size ce in (* produce r on the stack and then think about where to put that *) let ce = codegen_exp le ce RightAligned r in let () = assert (1 + original_stack_size = stack_size ce) in let ce = put_stacktop_into_lexp le ce layout l in let () = assert (original_stack_size = stack_size ce) in (le, ce) let push_event_signature ce event = let hash = Ethereum.event_signature_hash event in let ce = append_instruction ce (PUSH4 (Big (WrapBn.hex_to_big_int hash))) in ce let add_variable_init le ce layout i = let position = stack_size ce in let ce = codegen_exp le ce RightAligned i.Syntax.variable_init_value in let name = i.Syntax.variable_init_name in let loc = Location.Stack (position + 1) in let le = LocationEnv.add_pair le name loc in (le, ce) let rec add_if_single le ce (layout : LayoutInfo.layout_info) cond body = let jump_label_skip = Label.new_label () in let original_stack_size = stack_size ce in let ce = codegen_exp le ce RightAligned cond in let ce = append_instruction ce ISZERO in let ce = append_label ce jump_label_skip in let ce = append_instruction ce JUMPI in let le, ce = add_sentences le ce layout body in let ce = append_instruction ce (JUMPDEST jump_label_skip) in let () = assert (original_stack_size = stack_size ce) in (le, ce) and add_if le ce (layout : LayoutInfo.layout_info) cond bodyT bodyF = let jump_label_false = Label.new_label () in let jump_label_end = Label.new_label () in let original_stack_size = stack_size ce in let ce = codegen_exp le ce RightAligned cond in let ce = append_instruction ce ISZERO in let ce = append_label ce jump_label_false in let ce = append_instruction ce JUMPI in let _, ce = add_sentences le ce layout bodyT in (* location env needs to be discarded *) let ce = append_label ce jump_label_end in let ce = append_instruction ce JUMP in let ce = append_instruction ce (JUMPDEST jump_label_false) in let _, ce = add_sentences le ce layout bodyF in (* location env needs to be discarded *) let ce = append_instruction ce (JUMPDEST jump_label_end) in let () = assert (original_stack_size = stack_size ce) in (le, ce) and add_sentences le ce layout ss = List.fold_left (fun (le, ce) s -> add_sentence le ce layout s) (le, ce) ss and add_sentence le ce (layout : LayoutInfo.layout_info) sent = match sent with | AbortSentence -> (le, add_throw ce) | ReturnSentence ret -> add_return le ce layout ret | AssignmentSentence (l, r) -> add_assignment le ce layout l r | VariableInitSentence i -> add_variable_init le ce layout i | IfThenOnly (cond, body) -> add_if_single le ce layout cond body (* this is a special case of the next *) | IfThenElse (cond, bodyT, bodyF) -> add_if le ce layout cond bodyT bodyF | SelfdestructSentence exp -> add_self_destruct le ce layout exp | ExpSentence exp -> add_exp_sentence le ce layout exp | LogSentence (name, args, Some event) -> add_log_sentence le ce layout name args event | LogSentence (name, args, None) -> failwith "add_sentence: type check first" and add_log_sentence le ce layout name (args : Syntax.typ Syntax.exp list) event = let orig_stack_size = stack_size ce in (* get the indexed *) let (indexed_args, non_indexed_args) = Syntax.split_event_args event args in (* prepare indexed arguments on the stack *) let (le, ce) = prepare_words_on_stack le ce indexed_args in (* prepare the event signature on the stack *) let ce = push_event_signature ce event in (* prepare non-indexed arguments in the memory *) let (le, ce) = place_exps_in_memory le ce ABIPacking non_indexed_args in (* stack : [..., size, offset] *) let n = List.length indexed_args + 1 in let ce = append_instruction ce (log n) in (* decide N in logN *) let () = assert (stack_size ce = orig_stack_size) in le, ce and add_exp_sentence le ce layout exp = let ce = codegen_exp le ce RightAligned exp in let ce = append_instruction ce POP in le, ce and add_self_destruct le ce layout exp = let ce = codegen_exp le ce RightAligned exp in let ce = append_instruction ce SUICIDE in le, ce let add_case_argument_locations (le : LocationEnv.t) (case : Syntax.typ Syntax.case) = let additions : (string * Location.location) list = Ethereum.arguments_with_locations case in let ret = LocationEnv.add_pairs le additions in ret let calldatasize_of_usual_header us = let args = us.case_arguments in 4 (* for signature *) + try WrapList.sum (List.map (fun x -> Ethereum.(interface_typ_size (interpret_interface_type x.arg_typ))) args) with Invalid_argument _ -> 0 let add_case_argument_length_check ce case_header = match case_header with | DefaultCaseHeader -> (* no check, the choice is arguable *) ce | UsualCaseHeader us -> let ce = append_instruction ce (PUSH4 (Int (calldatasize_of_usual_header us))) in let ce = append_instruction ce CALLDATASIZE in let ce = append_instruction ce EQ in let ce = append_instruction ce ISZERO in let ce = append_instruction ce (PUSH1 (Int 0)) in let ce = append_instruction ce JUMPI in ce let add_case (le : LocationEnv.t) (ce : CodegenEnv.t) layout (cid : Assoc.contract_id) (case : Syntax.typ Syntax.case) = let ce = add_case_destination ce cid case.case_header in let ce = add_case_argument_length_check ce case.case_header in let le = LocationEnv.add_empty_block le in let le = add_case_argument_locations le case in let ((le : LocationEnv.t), ce) = List.fold_left (fun ((le : LocationEnv.t), ce) sent -> add_sentence le ce layout sent) (le, ce) case.case_body in (le, ce) let codegen_append_contract_bytecode le ce layout ((cid, contract) : Assoc.contract_id * Syntax.typ Syntax.contract) = (* jump destination for the contract *) let entry_label = Label.new_label () in let ce = append_instruction ce (JUMPDEST entry_label) in (* update the entrypoint database with (id, pc) pair *) let () = EntrypointDatabase.(register_entrypoint (Contract cid) entry_label) in let ce = initialize_memory_allocator ce in (* add jumps to the cases *) let (le, ce) = add_dispatcher le ce cid contract in (* add the cases *) let cases = contract.Syntax.contract_cases in let (le, ce) = List.fold_left (fun (le,ce) case -> add_case le ce layout cid case) (le, ce) cases in ce let append_runtime layout (prev : runtime_compiled) ((cid : Assoc.contract_id), (contract : Syntax.typ Syntax.contract)) : runtime_compiled = { runtime_codegen_env = codegen_append_contract_bytecode (LocationEnv.runtime_initial_env contract) prev.runtime_codegen_env layout (cid, contract) ; runtime_contract_offsets = Assoc.insert cid (CodegenEnv.code_length prev.runtime_codegen_env) prev.runtime_contract_offsets } let compile_runtime layout (contracts : Syntax.typ Syntax.contract Assoc.contract_id_assoc) : runtime_compiled = List.fold_left (append_runtime layout) (initial_runtime_compiled (cid_lookup_in_assoc contracts) contracts) contracts let layout_info_from_constructor_compiled (cc : constructor_compiled) : LayoutInfo.contract_layout_info = LayoutInfo.layout_info_of_contract cc.constructor_contract (CodegenEnv.ce_program cc.constructor_codegen_env) let sizes_of_constructors (constructors : constructor_compiled Assoc.contract_id_assoc) : int list = let lengths = Assoc.map (fun cc -> CodegenEnv.code_length cc.constructor_codegen_env) constructors in let lengths = List.sort (fun a b -> compare (fst a) (fst b)) lengths in List.map snd lengths let rec calculate_offsets_inner ret current lst = match lst with | [] -> List.rev ret | hd::tl -> (* XXX: fix the append *) calculate_offsets_inner (current :: ret) (current + hd) tl let calculate_offsets initial lst = calculate_offsets_inner [] initial lst let layout_info_from_runtime_compiled (rc : runtime_compiled) (constructors : constructor_compiled Assoc.contract_id_assoc) : LayoutInfo.runtime_layout_info = let sizes_of_constructors = sizes_of_constructors constructors in let offsets_of_constructors = calculate_offsets (CodegenEnv.code_length rc.runtime_codegen_env) sizes_of_constructors in let sum_of_constructor_sizes = WrapList.sum sizes_of_constructors in LayoutInfo.( { runtime_code_size = sum_of_constructor_sizes + CodegenEnv.code_length rc.runtime_codegen_env ; runtime_offset_of_contract_id = rc.runtime_contract_offsets ; runtime_size_of_constructor = Assoc.list_to_contract_id_assoc sizes_of_constructors ; runtime_offset_of_constructor = Assoc.list_to_contract_id_assoc offsets_of_constructors }) let programs_concat_reverse_order (programs : 'imm Evm.program list) = let rev_programs = List.rev programs in List.concat rev_programs (** constructors_packed concatenates constructor code. * Since the code is stored in the reverse order, the concatenation is also reversed. *) let constructors_packed layout (constructors : constructor_compiled Assoc.contract_id_assoc) = let programs = Assoc.map (fun cc -> CodegenEnv.ce_program cc.constructor_codegen_env) constructors in let programs = List.sort (fun a b -> compare (fst a) (fst b)) programs in let programs = List.map snd programs in programs_concat_reverse_order programs let compose_bytecode (constructors : constructor_compiled Assoc.contract_id_assoc) (runtime : runtime_compiled) (cid : Assoc.contract_id) : WrapBn.t Evm.program = let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let runtime_layout = layout_info_from_runtime_compiled runtime constructors in let layout = LayoutInfo.construct_post_layout_info contracts_layout_info runtime_layout in let pseudo_constructor = Assoc.choose_contract cid constructors in let imm_constructor = LayoutInfo.realize_pseudo_program layout cid (CodegenEnv.ce_program pseudo_constructor.constructor_codegen_env) in let pseudo_runtime_core = CodegenEnv.ce_program runtime.runtime_codegen_env in (* XXX: This part is somehow not modular. *) (* Sicne the code is stored in the reverse order, the concatenation is also reversed. *) let imm_runtime = LayoutInfo.realize_pseudo_program layout cid ((constructors_packed layout constructors)@pseudo_runtime_core) in (* the code is stored in the reverse order *) imm_runtime@imm_constructor let compose_runtime_bytecode (constructors : constructor_compiled Assoc.contract_id_assoc) (runtime : runtime_compiled) : WrapBn.t Evm.program = let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let runtime_layout = layout_info_from_runtime_compiled runtime constructors in let layout = LayoutInfo.construct_post_layout_info contracts_layout_info runtime_layout in (* TODO: 0 in the next line is a bit ugly. *) let imm_runtime = LayoutInfo.realize_pseudo_program layout 0 ((constructors_packed layout constructors)@(CodegenEnv.ce_program runtime.runtime_codegen_env)) in imm_runtime ================================================ FILE: src/codegen/codegen.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: 2e0624f260757657eae4c2d0f51f273f) CodegenEnv Codegen EntrypointDatabase LayoutInfo LocationEnv Parse # OASIS_STOP ================================================ FILE: src/codegen/codegen.mli ================================================ type alignment = LeftAligned | RightAligned (** [codegen_exp original_env exp] * is a new codegenEnv where a stack element is pushed, whose * value is the evaluation of exp *) val codegen_exp : LocationEnv.t -> CodegenEnv.t -> alignment -> Syntax.typ Syntax.exp -> CodegenEnv.t val codegen_sentence : CodegenEnv.t -> Syntax.typ Syntax.sentence -> (* is this enough? also add sentence Id's around? * I think this is enough. *) CodegenEnv.t type constructor_compiled = { constructor_codegen_env : CodegenEnv.t ; constructor_interface : Contract.contract_interface ; constructor_contract : Syntax.typ Syntax.contract } val compile_constructor : (Syntax.typ Syntax.contract Assoc.contract_id_assoc * Assoc.contract_id) -> constructor_compiled type runtime_compiled = { runtime_codegen_env : CodegenEnv.t ; runtime_contract_offsets : int Assoc.contract_id_assoc } val compile_runtime : LayoutInfo.layout_info -> Syntax.typ Syntax.contract Assoc.contract_id_assoc -> runtime_compiled (* TODO: remove from the interface. * Use instead compile_constructor *) val codegen_constructor_bytecode : (Syntax.typ Syntax.contract Assoc.contract_id_assoc * Assoc.contract_id) -> ((* LocationEnv.location_env * *) CodegenEnv.t (* containing the program *)) val compile_constructors : Syntax.typ Syntax.contract Assoc.contract_id_assoc -> constructor_compiled Assoc.contract_id_assoc val layout_info_from_constructor_compiled : constructor_compiled -> LayoutInfo.contract_layout_info val layout_info_from_runtime_compiled : runtime_compiled -> constructor_compiled Assoc.contract_id_assoc -> LayoutInfo.runtime_layout_info (** The combination of the constructor_bytecode and the runtime_bytecode **) val codegen_bytecode : Syntax.typ Syntax.contract -> PseudoImm.pseudo_imm Evm.program val move_info_around : (* assumption *) CodegenEnv.t -> (* goal *) LocationEnv.t -> CodegenEnv.t val compose_bytecode : constructor_compiled Assoc.contract_id_assoc -> runtime_compiled -> Assoc.contract_id -> WrapBn.t Evm.program val compose_runtime_bytecode : constructor_compiled Assoc.contract_id_assoc -> runtime_compiled -> WrapBn.t Evm.program ================================================ FILE: src/codegen/codegen.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: 2e0624f260757657eae4c2d0f51f273f) CodegenEnv Codegen EntrypointDatabase LayoutInfo LocationEnv Parse # OASIS_STOP ================================================ FILE: src/codegen/codegenEnv.ml ================================================ type t = { ce_stack_size: int ; ce_program: PseudoImm.pseudo_imm Evm.program ; ce_cid_lookup : string -> Assoc.contract_id ; ce_contracts : Syntax.typ Syntax.contract Assoc.contract_id_assoc } let ce_program m = m.ce_program let empty_env cid_lookup contracts = { ce_stack_size = 0 ; ce_program = Evm.empty_program ; ce_cid_lookup = cid_lookup ; ce_contracts = contracts } let code_length ce = Evm.size_of_program ce.ce_program let stack_size ce = ce.ce_stack_size let set_stack_size ce i = { ce with ce_stack_size = i } let append_instruction (orig : t) (i : PseudoImm.pseudo_imm Evm.instruction) : t = if orig.ce_stack_size < Evm.stack_eaten i then failwith "stack underflow" else let () = (match i with Evm.JUMPDEST l -> begin try ignore (Label.lookup_value l) with Not_found -> Label.register_value l (code_length orig) end | _ -> () ) in let new_stack_size = orig.ce_stack_size - Evm.stack_eaten i + Evm.stack_pushed i in if new_stack_size > 1024 then failwith "stack overflow" else { ce_stack_size = new_stack_size ; ce_program = Evm.append_inst orig.ce_program i ; ce_cid_lookup = orig.ce_cid_lookup ; ce_contracts = orig.ce_contracts } let cid_lookup ce = ce.ce_cid_lookup let contract_lookup (ce : t) (cid : Assoc.contract_id) : Syntax.typ Syntax.contract = try Assoc.choose_contract cid ce.ce_contracts with e -> let () = Printf.eprintf "contract_lookup failed on %d\n%!" cid in let () = (Assoc.print_int_for_cids (fun x -> x) (Assoc.cids ce.ce_contracts)) in raise e ================================================ FILE: src/codegen/codegenEnv.mli ================================================ (* codegenEnv remembers the current stack size, initial storage assumtion, and accumulated instructions. *) type t val empty_env : (string -> Assoc.contract_id) -> (Syntax.typ Syntax.contract Assoc.contract_id_assoc) -> t val ce_program : t -> PseudoImm.pseudo_imm Evm.program val code_length : t -> int val stack_size : t -> int val set_stack_size : t -> int -> t (* for each instruction, * create an interface function. * This allows keeping track of stack size... *) val append_instruction : t -> PseudoImm.pseudo_imm Evm.instruction -> t val cid_lookup : t -> string -> Assoc.contract_id val contract_lookup : t -> Assoc.contract_id -> Syntax.typ Syntax.contract ================================================ FILE: src/codegen/codegen_test.ml ================================================ open Syntax open Codegen (* The following two functions comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) let _ = let dummy_cid_lookup (_ : string) = 3 in let dummy_env = CodegenEnv.empty_env dummy_cid_lookup [] in let dummy_l = LocationEnv.empty_env in let _ = codegen_exp dummy_l dummy_env RightAligned (FalseExp, BoolType) in let _ = codegen_exp dummy_l dummy_env RightAligned (TrueExp, BoolType) in let _ = codegen_exp dummy_l dummy_env RightAligned (NotExp (TrueExp, BoolType), BoolType) in let _ = codegen_exp dummy_l dummy_env RightAligned (NowExp, Uint256Type) in Printf.printf "Finished codgen_test.\n" ================================================ FILE: src/codegen/codegen_test2.ml ================================================ open Lexer open Lexing open Printf open Syntax open Codegen let _ = let lexbuf = Lexing.from_channel stdin in let contracts : unit Syntax.toplevel list = Parse.parse_with_error lexbuf in let contracts = Assoc.list_to_contract_id_assoc contracts in let contracts : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc = Type.assign_types contracts in let contracts = Assoc.filter_map (fun x -> match x with | Contract x -> Some x | _ -> None) contracts in let () = match contracts with | [] -> () | _ -> let (env : CodegenEnv.t) = codegen_constructor_bytecode (contracts, fst (List.hd contracts)) in let constructor_program = CodegenEnv.ce_program env in let () = Printf.printf "=====constructor for first contract=====\n" in let () = Evm.print_pseudo_program constructor_program in let () = Printf.printf "=====runtime code (common to all contracts)=====\n" in let constructors : constructor_compiled Assoc.contract_id_assoc = compile_constructors contracts in let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let layout = LayoutInfo.construct_layout_info contracts_layout_info in let runtime_compiled = compile_runtime layout contracts in let runtime_ce = runtime_compiled.runtime_codegen_env in let () = Evm.print_pseudo_program (CodegenEnv.ce_program runtime_ce) in let () = Printf.printf "=====layout_info (common to all contracts)=====\n" in let layout = LayoutInfo.construct_layout_info contracts_layout_info in let () = LayoutInfo.print_layout_info layout in let () = Printf.printf "=====bytecode (with the constructor for first contract)=====\n" in let bytecode : WrapBn.t Evm.program = compose_bytecode constructors runtime_compiled (fst (List.hd contracts)) in let () = Evm.print_imm_program bytecode in let () = Printf.printf "=====runtime bytecode=====\n" in let runtime_bytecode : WrapBn.t Evm.program = compose_runtime_bytecode constructors runtime_compiled in let () = Evm.print_imm_program runtime_bytecode in () in Printf.printf "Finished codgen_test2.\n" ================================================ FILE: src/codegen/entrypointDatabase.ml ================================================ type entrypoint = | Contract of Assoc.contract_id | Case of Assoc.contract_id * Syntax.case_header let store : (entrypoint * Label.label) list ref = ref [] let register_entrypoint (k : entrypoint) (v : Label.label) : unit = store := (k, v) :: !store let lookup_entrypoint (k : entrypoint) : Label.label = List.assoc k !store ================================================ FILE: src/codegen/entrypointDatabase.mli ================================================ type entrypoint = | Contract of Assoc.contract_id | Case of Assoc.contract_id * Syntax.case_header val register_entrypoint : entrypoint -> Label.label -> unit val lookup_entrypoint : entrypoint -> Label.label ================================================ FILE: src/codegen/layoutInfo.ml ================================================ (* Layout information that should be available after the constructor compilation finishes *) type layout_info = { contract_ids : Assoc.contract_id list ; constructor_code_size : Assoc.contract_id -> int (* numbers about the storage *) (* The storage during the runtime looks like this: *) (* |current pc (might be entry_pc_of_current_contract)|array seed counter|pod contract argument0|pod contract argument1|... |array0's seed|array1's seed| *) (* In addition, array elements are placed at the same location as in Solidity *) ; storage_current_pc_index : int ; storage_array_counter_index : int ; storage_constructor_arguments_begin : Assoc.contract_id -> int ; storage_constructor_arguments_size : Assoc.contract_id -> int ; storage_array_seeds_begin : Assoc.contract_id -> int ; storage_array_seeds_size : Assoc.contract_id -> int } (* Layout information that should be available after the runtime compilation finishes. *) type post_layout_info = { (* The initial data is organized like this: *) (* |constructor code|runtime code|constructor arguments| *) init_data_size : Assoc.contract_id -> int (* runtime_coode_offset is equal to constructor_code_size *) ; runtime_code_size : int ; contract_offset_in_runtime_code : int Assoc.contract_id_assoc (* And then, the runtime code is organized like this: *) (* |dispatcher that jumps into the stored pc|runtime code for contract A|runtime code for contract B|runtime code for contract C| *) ; constructor_in_runtime_code_offset : int Assoc.contract_id_assoc (* And then, the runtime code for a particular contract is organized like this: *) (* |dispatcher that jumps into a case|runtime code for case f|runtime code for case g| *) ; l : layout_info } let print_layout_info l = let () = Printf.printf "layout_info\n" in let () = Printf.printf " init_data_size:" in let () = Printf.printf "\n" in () type contract_layout_info = { contract_constructor_code_size : int ; contract_argument_size : int (** the number of words that the contract arguments occupy *) ; contract_num_array_seeds : int (** the number of arguments that arrays *) ; contract_args : Syntax.typ list (** the list of argument types *) } type runtime_layout_info = { runtime_code_size : int ; runtime_offset_of_contract_id : int Assoc.contract_id_assoc ; runtime_offset_of_constructor : int Assoc.contract_id_assoc ; runtime_size_of_constructor : int Assoc.contract_id_assoc } let compute_constructor_code_size lst cid = let c : contract_layout_info = Assoc.choose_contract cid lst in c.contract_constructor_code_size let compute_constructor_arguments_size lst cid = let c : contract_layout_info = Assoc.choose_contract cid lst in c.contract_argument_size let compute_constructor_arguments_begin lst runtime cid = compute_constructor_code_size lst cid + runtime.runtime_code_size let compute_init_data_size lst runtime cid = compute_constructor_arguments_begin lst runtime cid + compute_constructor_arguments_size lst cid let compute_storage_constructor_arguments_begin lst cid = 2 let compute_storage_array_seeds_begin lst cid = compute_storage_constructor_arguments_begin lst cid + compute_constructor_arguments_size lst cid let compute_storage_array_seeds_size lst cid = let c = Assoc.choose_contract cid lst in c.contract_num_array_seeds let construct_layout_info (lst : (Assoc.contract_id * contract_layout_info) list) : layout_info = { contract_ids = List.map fst lst ; constructor_code_size = compute_constructor_code_size lst ; storage_current_pc_index = 0 (* This is a magic constant. *) ; storage_array_counter_index = 1 (* This is also a magic constant. *) ; storage_constructor_arguments_begin = compute_storage_constructor_arguments_begin lst ; storage_constructor_arguments_size = compute_constructor_arguments_size lst ; storage_array_seeds_begin = compute_storage_array_seeds_begin lst ; storage_array_seeds_size = compute_storage_array_seeds_size lst } let construct_post_layout_info (lst : (Assoc.contract_id * contract_layout_info) list) (runtime : runtime_layout_info) : post_layout_info = { init_data_size = compute_init_data_size lst runtime ; runtime_code_size = runtime.runtime_code_size ; contract_offset_in_runtime_code = runtime.runtime_offset_of_contract_id ; l = construct_layout_info lst ; constructor_in_runtime_code_offset = runtime.runtime_offset_of_constructor } (* Assuming the layout described above, this definition makes sense. *) let runtime_code_offset (layout : layout_info) (cid : Assoc.contract_id) : int = layout.constructor_code_size cid let rec realize_pseudo_imm (layout : post_layout_info) (initial_cid : Assoc.contract_id) (p : PseudoImm.pseudo_imm) : WrapBn.t = PseudoImm.( match p with | Big b -> b | Int i -> WrapBn.big_int_of_int i | DestLabel l -> WrapBn.big_int_of_int (Label.lookup_value l) | StorageProgramCounterIndex -> WrapBn.big_int_of_int (layout.l.storage_current_pc_index) | StorageConstructorArgumentsBegin cid -> WrapBn.big_int_of_int (layout.l.storage_constructor_arguments_begin cid) | StorageConstructorArgumentsSize cid -> WrapBn.big_int_of_int (layout.l.storage_constructor_arguments_size cid) | InitDataSize cid -> WrapBn.big_int_of_int (layout.init_data_size cid) | RuntimeCodeOffset cid -> WrapBn.big_int_of_int (runtime_code_offset layout.l cid) | RuntimeCodeSize -> WrapBn.big_int_of_int (layout.runtime_code_size) | ConstructorCodeSize cid -> WrapBn.big_int_of_int (layout.l.constructor_code_size cid) | ConstructorInRuntimeCodeOffset cid -> WrapBn.big_int_of_int (Assoc.choose_contract cid layout.constructor_in_runtime_code_offset) | ContractOffsetInRuntimeCode cid -> WrapBn.big_int_of_int (Assoc.choose_contract cid layout.contract_offset_in_runtime_code) | CaseOffsetInRuntimeCode (cid, case_header) -> let label = EntrypointDatabase.(lookup_entrypoint (Case (cid, case_header))) in let v = Label.lookup_value label in WrapBn.big_int_of_int v | Minus (a, b) -> WrapBn.sub_big_int (realize_pseudo_imm layout initial_cid a) (realize_pseudo_imm layout initial_cid b) ) let realize_pseudo_instruction (l : post_layout_info) (initial_cid : Assoc.contract_id) (i : PseudoImm.pseudo_imm Evm.instruction) : WrapBn.t Evm.instruction = Evm.( match i with | PUSH1 imm -> PUSH1 (realize_pseudo_imm l initial_cid imm) | PUSH4 imm -> PUSH4 (realize_pseudo_imm l initial_cid imm) | PUSH32 imm -> PUSH32 (realize_pseudo_imm l initial_cid imm) | NOT -> NOT | TIMESTAMP -> TIMESTAMP | EQ -> EQ | ISZERO -> ISZERO | LT -> LT | GT -> GT | BALANCE -> BALANCE | STOP -> STOP | ADD -> ADD | MUL -> MUL | SUB -> SUB | DIV -> DIV | SDIV -> SDIV | MOD -> MOD | SMOD -> SMOD | ADDMOD -> ADDMOD | MULMOD -> MULMOD | EXP -> EXP | SIGNEXTEND -> SIGNEXTEND | SHA3 -> SHA3 | ADDRESS -> ADDRESS | ORIGIN -> ORIGIN | CALLER -> CALLER | CALLVALUE -> CALLVALUE | CALLDATALOAD -> CALLDATALOAD | CALLDATASIZE -> CALLDATASIZE | CALLDATACOPY -> CALLDATACOPY | CODESIZE -> CODESIZE | CODECOPY -> CODECOPY | GASPRICE -> GASPRICE | EXTCODESIZE -> EXTCODESIZE | EXTCODECOPY -> EXTCODECOPY | POP -> POP | MLOAD -> MLOAD | MSTORE -> MSTORE | MSTORE8 -> MSTORE8 | SLOAD -> SLOAD | SSTORE -> SSTORE | JUMP -> JUMP | JUMPI -> JUMPI | PC -> PC | MSIZE -> MSIZE | GAS -> GAS | JUMPDEST l -> JUMPDEST l | LOG0 -> LOG0 | LOG1 -> LOG1 | LOG2 -> LOG2 | LOG3 -> LOG3 | LOG4 -> LOG4 | CREATE -> CREATE | CALL -> CALL | CALLCODE -> CALLCODE | RETURN -> RETURN | DELEGATECALL -> DELEGATECALL | SUICIDE -> SUICIDE | SWAP1 -> SWAP1 | SWAP2 -> SWAP2 | SWAP3 -> SWAP3 | SWAP4 -> SWAP4 | SWAP5 -> SWAP5 | SWAP6 -> SWAP6 | DUP1 -> DUP1 | DUP2 -> DUP2 | DUP3 -> DUP3 | DUP4 -> DUP4 | DUP5 -> DUP5 | DUP6 -> DUP6 | DUP7 -> DUP7 ) let realize_pseudo_program (l : post_layout_info) (initial_cid : Assoc.contract_id) (p : PseudoImm.pseudo_imm Evm.program) : WrapBn.t Evm.program = List.map (realize_pseudo_instruction l initial_cid) p let layout_info_of_contract (c : Syntax.typ Syntax.contract) (constructor_code : PseudoImm.pseudo_imm Evm.program) = { contract_constructor_code_size = Evm.size_of_program constructor_code ; contract_argument_size = Ethereum.total_size_of_interface_args (List.map snd (Ethereum.constructor_arguments c)) ; contract_num_array_seeds = List.length (Ethereum.arrays_in_contract c) ; contract_args = List.map (fun a -> a.Syntax.arg_typ) (c.Syntax.contract_arguments) } let rec arg_locations_inner (offset : int) (used_plain_args : int) (used_mapping_seeds : int) (num_of_plains : int) (args : Syntax.typ list) : Storage.storage_location list = match args with | [] -> [] | h :: t -> if Syntax.is_mapping h then (offset + num_of_plains + used_mapping_seeds) :: arg_locations_inner offset used_plain_args (used_mapping_seeds + 1) num_of_plains t else (offset + used_plain_args) :: arg_locations_inner offset (used_plain_args + 1) used_mapping_seeds num_of_plains t (* this needs to take storage_constructor_arguments_begin *) let arg_locations (offset : int) (cntr : Syntax.typ Syntax.contract) : Storage.storage_location list = let argument_types = List.map (fun a -> a.Syntax.arg_typ) cntr.Syntax.contract_arguments in let () = assert (List.for_all Syntax.fits_in_one_storage_slot argument_types) in let num_of_plains = Syntax.count_plain_args argument_types in arg_locations_inner offset 0 0 num_of_plains argument_types let array_locations (cntr : Syntax.typ Syntax.contract) : Storage.storage_location list = let argument_types = List.map (fun a -> a.Syntax.arg_typ) cntr.Syntax.contract_arguments in let () = assert (List.for_all Syntax.fits_in_one_storage_slot argument_types) in let num_of_plains = Syntax.count_plain_args argument_types in let total_num = List.length argument_types in if total_num = num_of_plains then [] else WrapList.range (2 + num_of_plains) (total_num + 1) ================================================ FILE: src/codegen/layoutInfo.mli ================================================ (* Layout information that should be available after the constructor compilation finishes *) type layout_info = { contract_ids : Assoc.contract_id list ; constructor_code_size : Assoc.contract_id -> int (* numbers about the storage *) (* The storage during the runtime looks like this: *) (* |current pc (might be entry_pc_of_current_contract)|array seed counter|pod contract argument0|pod contract argument1|... |array0's seed|array1's seed| *) (* In addition, array elements are placed at the same location as in Solidity *) ; storage_current_pc_index : int ; storage_array_counter_index : int ; storage_constructor_arguments_begin : Assoc.contract_id -> int ; storage_constructor_arguments_size : Assoc.contract_id -> int ; storage_array_seeds_begin : Assoc.contract_id -> int ; storage_array_seeds_size : Assoc.contract_id -> int } (* Layout information that should be available after the runtime compilation finishes. *) type post_layout_info = { (* The initial data is organized like this: *) (* |constructor code|runtime code|constructor arguments| *) init_data_size : Assoc.contract_id -> int (* runtime_coode_offset is equal to constructor_code_size *) ; runtime_code_size : int ; contract_offset_in_runtime_code : int Assoc.contract_id_assoc (* And then, the runtime code is organized like this: *) (* |dispatcher that jumps into the stored pc|runtime code for contract A|runtime code for contract B|runtime code for contract C| |constructor code for contract A|constructor code for contract B|constructor code for contract C| *) ; constructor_in_runtime_code_offset : int Assoc.contract_id_assoc (* And then, the runtime code for a particular contract is organized like this: *) (* |dispatcher that jumps into a case|runtime code for case f|runtime code for case g| *) ; l : layout_info } (* [Storage layout for arrays] * For each array argument of a contract, the storage contains a seed. * array[x][y] would be stored at the location sha3(sha3(seed_of(array), x), y). * There needs to be utility funcitons for computing this hash value and using it. * I think this comment should split out into its own module. *) val print_layout_info : layout_info -> unit type contract_layout_info = { contract_constructor_code_size : int (** the number of bytes that the constructor code occupies *) ; contract_argument_size : int (** the number of words that the contract arguments occupy *) ; contract_num_array_seeds : int (** the number of arguments that are arrays; todo: remove and create a function if needed *) ; contract_args : Syntax.typ list (** the list of argument types *) } val realize_pseudo_instruction : post_layout_info -> Assoc.contract_id -> PseudoImm.pseudo_imm Evm.instruction -> WrapBn.t Evm.instruction val realize_pseudo_program : post_layout_info -> Assoc.contract_id -> PseudoImm.pseudo_imm Evm.program -> WrapBn.t Evm.program val layout_info_of_contract : Syntax.typ Syntax.contract -> PseudoImm.pseudo_imm Evm.program (* constructor *) -> contract_layout_info val realize_pseudo_imm : post_layout_info -> Assoc.contract_id -> PseudoImm.pseudo_imm -> WrapBn.t type runtime_layout_info = { runtime_code_size : int ; runtime_offset_of_contract_id : int Assoc.contract_id_assoc ; runtime_offset_of_constructor : int Assoc.contract_id_assoc ; runtime_size_of_constructor : int Assoc.contract_id_assoc } val construct_layout_info : (Assoc.contract_id * contract_layout_info) list -> layout_info val construct_post_layout_info : (Assoc.contract_id * contract_layout_info) list -> runtime_layout_info -> post_layout_info (** [arg_locations offset cl] returns the list of storage locations where the arguments are stored. * [offset] should be the index of the first argument *) val arg_locations : int -> Syntax.typ Syntax.contract -> Storage.storage_location list (** [array_locations cr] returns the list of storage locations where the arrays are stored. *) val array_locations : Syntax.typ Syntax.contract -> Storage.storage_location list ================================================ FILE: src/codegen/layouts.txt ================================================ Storage: 000: program counter (which contract is it running now?) 001: n = number of words used in ABI arguments 002 - 002+n-1: ABI arguments The array elements are stored at sha3(array_id, idx) For the nesting arrays, sha3(sha3(array_id, first_idx), second_idx) and so on. Memory: 0-63 bytes are used for sha3 argument. The rest is currently unusued. Stack: usual. The location of the currently active variables are stored in locationEnv. ContractCreation: as in solc, the inputs are suffixed afer the creation code. ================================================ FILE: src/codegen/locationEnv.ml ================================================ open PseudoImm type t = (string * Location.location) list list let size l = WrapList.sum (List.map List.length l) let empty_env = [] let forget_innermost = function | (_ :: older) -> older | [] -> failwith "forget_innermost: no blocks to forget" (** [update_block [str] [new_loc] returns [None] when [str] is not found. * Otherwise, it returns the updated block. *) let update_block (str : string) (new_loc : Location.location) (block : (string * Location.location) list) : (string * Location.location) list option = failwith "update_block" let update (orig : t) (str : string) (new_loc : Location.location) : t option = Misc.change_first (update_block str new_loc) orig let lookup_block (search : string) (lst : (string * Location.location) list) : Location.location option = try Some (List.assoc search lst) with Not_found -> None let lookup (le : t) (search : string) : Location.location option = Misc.first_some (lookup_block search) le let add_pair (le : t) (key : string) (loc : Location.location) : t = match le with | [] -> failwith "add_pair: no block" | h :: t -> ((key, loc) :: h) :: t let add_pairs (le : t) (lst : (string * Location.location) list) : t = List.fold_left (fun le' (str, loc) -> add_pair le' str loc) le lst let add_empty_block orig = [] :: orig let stack_story_block (block : (string * Location.location) list) : int option = failwith "stack_story_block" let last_stack_element_recorded (le : t) = match Misc.first_some stack_story_block le with | Some n -> n | None -> -1 let constructor_args_locations (cid : Assoc.contract_id) (args : (string * Ethereum.interface_typ) list) : t = let total = Ethereum.total_size_of_interface_args (List.map snd args) in let one_arg ((name : string), (offset : int), (size : int)) : string * Location.location = Location.(name, Code { code_start = PseudoImm.(Minus (InitDataSize cid, (Int (total - offset)))) ; code_size = Int size }) in let rec name_offset_size_list rev_acc offset (args : (string * Ethereum.interface_typ) list) = match args with | [] -> List.rev rev_acc | (h_name, h_typ) :: t -> name_offset_size_list ((h_name, offset, Ethereum.interface_typ_size h_typ) :: rev_acc) (offset + Ethereum.interface_typ_size h_typ) t in [List.map one_arg (name_offset_size_list [] 0 args)] let constructor_initial_env (cid : Assoc.contract_id) (contract : Syntax.typ Syntax.contract) : t = let args = Ethereum.constructor_arguments contract in constructor_args_locations cid args (** [runtime_initial_t contract] * is a location environment that contains * the constructor arguments * after StorageConstrutorArgumentBegin *) let runtime_initial_env (contract : Syntax.typ Syntax.contract) : t = let plain = Ethereum.constructor_arguments contract in let init = add_empty_block empty_env in let f (lenv, word_idx) (name, typ) = let size_in_word = Ethereum.interface_typ_size typ / 32 in let loc = Location.(Storage { storage_start = Int word_idx; storage_size = Int size_in_word }) in let new_lenv = add_pair lenv name loc in (new_lenv, word_idx + size_in_word) in (* XXX: remove the hard coded 2 *) let (le, mid) = List.fold_left f (init, 2) plain in let arrays = Ethereum.arrays_in_contract contract in (* XXX: refactor the repetition *) let g (lenv, word_idx) (name, _, _) = let size_in_word = 1 in let loc = Location.(Storage { storage_start = Int word_idx; storage_size = Int size_in_word }) in let new_lenv = add_pair lenv name loc in (new_lenv, word_idx + size_in_word) in let (le, _) = List.fold_left g (le, mid) arrays in le ================================================ FILE: src/codegen/locationEnv.mli ================================================ type t val empty_env : t val forget_innermost : t -> t val add_empty_block : t -> t (** should maintain the uniqueless of [string] in the environment. *) val add_pair : t -> string (* ?? *) -> Location.location -> t val add_pairs : t -> (string * Location.location) list -> t val lookup : t -> string -> Location.location option (** [last_stack_element_recorded = 3] means the third deepest element of the * stack is kept track in the t structure. * The caller is free to pop anything shallower *) val last_stack_element_recorded : t -> int (** [update] returns [None] when the string is not in the environment. *) val update : t -> string -> Location.location -> t option (** [size l] returns the number of entries in [l] *) val size : t -> int (** Nothing similar to typeEnv.add_block. Add elements one by one. *) (** {2} concrete locationEnv instances *) (** [constructor_initial_env contract] * returns the location environment that contains * the expected input arguments at the end of the * bytecode *) val constructor_initial_env : Assoc.contract_id -> Syntax.typ Syntax.contract -> t (** [runtime_initial_env specifies * where the state variables should be found * when the runtie code starts. * The deployment bytecode must establish this. * Storage index 0 is used for contract dispatching. * The following indices are used to store the * state variables. *) val runtime_initial_env : Syntax.typ Syntax.contract -> t (** [constructor_args_locations constract] returns * a location environment that only contains * the constructor arguments appended at the end of * the code. *) val constructor_args_locations : Assoc.contract_id -> (string * Ethereum.interface_typ) list -> t ================================================ FILE: src/codegen/parse.ml ================================================ open Lexer open Lexing open Printf (* The following two functions comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) let print_position outx lexbuf = let pos = lexbuf.lex_curr_p in fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) let parse_with_error lexbuf = try Parser.file Lexer.read lexbuf with | SyntaxError msg -> fprintf stderr "%a: %s\n" print_position lexbuf msg; exit (-1) | Parser.Error -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) | _ -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) ================================================ FILE: src/codegen/parse.mli ================================================ val parse_with_error : Lexing.lexbuf -> unit Syntax.toplevel list ================================================ FILE: src/cross-platform/META ================================================ # OASIS_START # DO NOT EDIT (digest: c13f891232d5c3e0d504b5e1b0eb0164) version = "0.0.02" description = "A compiler targeting Ethereum Virtual Machine" requires = "batteries cryptokit hex" archive(byte) = "cross-platform.cma" archive(byte, plugin) = "cross-platform.cma" archive(native) = "cross-platform.cmxa" archive(native, plugin) = "cross-platform.cmxs" exists_if = "cross-platform.cma" # OASIS_STOP ================================================ FILE: src/cross-platform/cross-platform.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: 54339adac6e4801bdd3f49aa4a6fd723) Rope WrapBnNative WrapCryptokitNative WrapListNative WrapStringNative # OASIS_STOP ================================================ FILE: src/cross-platform/cross-platform.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: 54339adac6e4801bdd3f49aa4a6fd723) Rope WrapBnNative WrapCryptokitNative WrapListNative WrapStringNative # OASIS_STOP ================================================ FILE: src/cross-platform/rope.ml ================================================ (* Mostly copied from https://github.com/Chris00/ocaml-rope/blob/master/src/rope.ml Parts that are modified are marked with "Modified" and commented out *) (* File: rope.ml Copyright (C) 2007 Christophe Troestler email: Christophe.Troestler@umh.ac.be WWW: http://math.umh.ac.be/an/software/ This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License version 2.1 or later as published by the Free Software Foundation, with the special exception on linking described in the file LICENSE. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file LICENSE for more details. *) (** Rope implementation inspired from : Hans Boehm, Russ Atkinson, Michael Plass, "Ropes: an alternative to strings", Software Practice and Experience 25, vol. 12 (1995), pp. 1315-1330. http://www.cs.ubc.ca/local/reading/proceedings/spe91-95/spe/vol25/issue12/spe986.pdf *) (* TODO: - Regexp (maybe using Jérôme Vouillon regexp lib ? http://www.pps.jussieu.fr/~vouillon/) - Camomille interop. (with phantom types for encoding ??) See also the OSR http://cocan.org/osr/unicode_library *) let min i j = if (i:int) < j then i else j let max i j = if (i:int) > j then i else j exception Out_of_bounds of string (* One assumes throughout that the length is a representable integer. Public functions that allow to construct larger ropes must check this. *) type t = | Sub of string * int * int (* (s, i0, len) where only s.[i0 .. i0+len-1] is used by the rope. [len = 0] is forbidden, unless the rope has 0 length (i.e. it is empty). Experiments show that this is faster than [Sub of string] and does not really use more memory -- because splices share all nodes. *) | Concat of int * int * t * int * t (* [(height, length, left, left_length, right)]. This asymmetry between left and right was chosen because the full length and the left length are more often needed that the right length. *) type rope = t let small_rope_length = 32 (** Use this as leaf when creating fresh leaves. Also sub-ropes of length [<= small_rope_length] may be flattened by [concat2]. This value must be quite small, typically comparable to the size of a [Concat] node. *) let make_length_pow2 = 10 let make_length = 1 lsl make_length_pow2 let max_flatten_length = 1024 (** When deciding whether to flatten a rope, only those with length [<= max_flatten_length] will be. *) let extract_sub_length = small_rope_length / 2 (** When balancing, copy the substrings with this length or less (=> release the original string). *) let level_flatten = 12 (** When balancing, flatten the rope at level [level_flatten]. The sum of [min_length.(n)], [0 <= n <= level_flatten] must be of te same order as [max_flatten_length]. *) (* Fibonacci numbers $F_{n+2}$. By definition, a NON-EMPTY rope [r] is balanced iff [length r >= min_length.(height r)]. [max_height] is the first height at which the fib. number overflow the integer range. *) let min_length, max_height = (* Since F_{n+2} >= ((1 + sqrt 5)/2)^n, we know F_{d+2} will overflow: *) let d = (3 * Sys.word_size) / 2 in let m = Array.make d max_int in (* See [add_nonempty_to_forest] for the reason for [max_int] *) let prev = ref 0 and last = ref 1 and i = ref 0 in try while !i < d - 1 do let curr = !last + !prev in if curr < !last (* overflow *) then raise Exit; m.(!i) <- curr; prev := !last; last := curr; incr i done; assert false with Exit -> m, !i let rebalancing_height = min (max_height - 1) 60 (** Beyond this height, implicit balance will be done. This value allows gross inefficiencies while not being too time consuming. For example, explicit rebalancing did not really improve the running time on the ICFP 2007 task. *) (* 32 bits: max_height - 1 = 42 *) let empty = Sub("", 0, 0) let length = function | Sub(_, _, len) -> len | Concat(_,len,_,_,_) -> len let height = function | Sub(_,_,_) -> 0 | Concat(h,_,_,_,_) -> h let is_empty = function | Sub(_, _, len) -> len = 0 | _ -> false let is_not_empty = function | Sub(_, _, len) -> len <> 0 | _ -> true (* For debugging purposes and judging the balancing *) let print = let rec map_left = function | [] -> [] | [x] -> ["/" ^ x] | x :: tl -> (" " ^ x) :: map_left tl in let map_right = function | [] -> [] | x :: tl -> ("\\" ^ x) :: List.map (fun r -> " " ^ r) tl in let rec leaves_list = function | Sub(s, i0, len) -> [String.sub s i0 len] | Concat(_,_, l,_, r) -> map_left(leaves_list l) @ map_right(leaves_list r) in fun r -> List.iter print_endline (leaves_list r) ;; let of_string s = Sub(s, 0, String.length s) (* safe: string is now immutable *) (* Since we will need to copy the string anyway, let us take this opportunity to split it in small chunks for easier further sharing. In order to minimize the height, we use a simple bisection scheme. *) let rec unsafe_of_substring s i len = if len <= small_rope_length then Sub(String.sub s i len, 0, len) else let len' = len / 2 in let i' = i + len' in let left = unsafe_of_substring s i len' and right = unsafe_of_substring s i' (len - len') in let h = 1 + max (height left) (height right) in let ll = length left in Concat(h, ll + length right, left, ll, right) let of_substring s i len = let len_s = String.length s in if i < 0 || len < 0 || i > len_s - len then invalid_arg "Rope.of_substring"; (* If only a small percentage of the string is not in the rope, do not cut the string in small pieces. The case of small lengths is managed by [unsafe_of_substring]. *) if len >= len_s - (len / 10) then Sub(s, i, len) else unsafe_of_substring s i len let of_char c = Sub(String.make 1 c, 0, 1) (* Construct a rope from [n-1] copies of a call to [gen ofs len] of length [len = make_length] and a last call with the remainder length. So the tree has [n] leaves [Sub]. The strings returned by [gen ofs len] may be longer than [len] of only the first [len] chars will be used. *) let rec make_of_gen gen ofs len ~n = if n <= 1 then if len > 0 then Sub(gen ofs len, 0, len) else empty else let nl = n / 2 in let ll = nl * max_flatten_length in let l = make_of_gen gen ofs ll ~n:nl in let r = make_of_gen gen (ofs + ll) (len - ll) ~n:(n - nl) in Concat(1 + max (height l) (height r), len, l, ll, r) let make_length_mask = make_length - 1 let make_n_chunks len = if len land make_length_mask = 0 then len lsr make_length_pow2 else len lsr make_length_pow2 + 1 let make len c = if len < 0 then failwith "Rope.make: len must be >= 0"; if len <= make_length then Sub(String.make len c, 0, len) else let base = String.make make_length c in make_of_gen (fun _ _ -> base) 0 len ~n:(make_n_chunks len) let init len f = if len < 0 then failwith "Rope.init: len must be >= 0"; if len <= make_length then Sub(String.init len f, 0, len) else (* Do not use String.init to avoid creating a closure. *) let gen ofs len = let b = Bytes.create len in for i = 0 to len - 1 do Bytes.set b i (f (ofs + i)) done; Bytes.unsafe_to_string b in make_of_gen gen 0 len ~n:(make_n_chunks len) (* [copy_to_subbytes t ofs r] copy the rope [r] to the byte range [t.[ofs .. ofs+(length r)-1]]. It is assumed that [t] is long enough. (This function could be a one liner with [iteri] but we want to use [Bytes.blit_string] for efficiency.) *) let rec copy_to_subbytes t ofs = function | Sub(s, i0, len) -> Bytes.blit_string s i0 t ofs len | Concat(_, _, l,ll, r) -> copy_to_subbytes t ofs l; copy_to_subbytes t (ofs + ll) r let to_string = function | Sub(s, i0, len) -> (* Optimize when the rope hold a single string. *) if i0 = 0 && len = String.length s then s else String.sub s i0 len | r -> let len = length r in if len > Sys.max_string_length then failwith "Rope.to_string: rope length > Sys.max_string_length"; let t = Bytes.create len in copy_to_subbytes t 0 r; Bytes.unsafe_to_string t (* Similar to [copy_to_subbytes] do more work to allow specifying a range of [src]. *) let rec unsafe_blit src srcofs dst dstofs len = match src with | Sub(s, i0, _) -> String.blit s (i0 + srcofs) dst dstofs len | Concat(_, _, l, ll, r) -> let rofs = srcofs - ll in if rofs >= 0 then unsafe_blit r rofs dst dstofs len else let llen = - rofs in (* # of chars after [srcofs] in the left rope *) if len <= llen then unsafe_blit l srcofs dst dstofs len else (* len > llen *) ( unsafe_blit l srcofs dst dstofs llen; unsafe_blit r 0 dst (dstofs + llen) (len - llen); ) let blit src srcofs dst dstofs len = if len < 0 then failwith "Rope.blit: len >= 0 required"; if srcofs < 0 || srcofs > length src - len then failwith "Rope.blit: not a valid range of src"; if dstofs < 0 || dstofs > Bytes.length dst - len then failwith "Rope.blit: not a valid range of dst"; unsafe_blit src srcofs dst dstofs len (* Flatten a rope (avoids unecessary copying). *) let flatten = function | Sub(_,_,_) as r -> r | r -> let len = length r in assert(len <= Sys.max_string_length); let t = Bytes.create len in copy_to_subbytes t 0 r; Sub(Bytes.unsafe_to_string t, 0, len) let rec get rope i = match rope with | Sub(s, i0, len) -> if i < 0 || i >= len then raise(Out_of_bounds "Rope.get") else s.[i0 + i] | Concat(_,_, l, left_len, r) -> if i < left_len then get l i else get r (i - left_len) let rec iter f = function | Sub(s, i0, len) -> for i = i0 to i0 + len - 1 do f s.[i] done | Concat(_, _, l,_, r) -> iter f l; iter f r let rec iteri_rec f init = function | Sub(s, i0, len) -> let offset = init - i0 in for i = i0 to i0 + len - 1 do f (i + offset) s.[i] done | Concat(_, _, l,ll, r) -> iteri_rec f init l; iteri_rec f (init + ll) r let iteri f r = ignore(iteri_rec f 0 r) let rec map ~f = function | Sub(s, i0, len) -> let b = Bytes.create len in for i = 0 to len - 1 do Bytes.set b i (f (String.unsafe_get s (i0 + i))) done; Sub(Bytes.unsafe_to_string b, 0, len) | Concat(h, len, l, ll, r) -> let l = map ~f l in let r = map ~f r in Concat(h, len, l, ll, r) let rec mapi_rec ~f idx0 = function | Sub(s, i0, len) -> let b = Bytes.create len in for i = 0 to len - 1 do Bytes.set b i (f (idx0 + i) s.[i0 + i]) done; Sub(Bytes.unsafe_to_string b, 0, len) | Concat(h, len, l, ll, r) -> let l = mapi_rec ~f idx0 l in let r = mapi_rec ~f (idx0 + ll) r in Concat(h, len, l, ll, r) let mapi ~f r = mapi_rec ~f 0 r (** Balancing ***********************************************************************) (* Fast, no fuss, concatenation. *) let balance_concat rope1 rope2 = let len1 = length rope1 and len2 = length rope2 in if len1 = 0 then rope2 else if len2 = 0 then rope1 else let h = 1 + max (height rope1) (height rope2) in Concat(h, len1 + len2, rope1, len1, rope2) (* Invariants for [forest]: 1) The concatenation of the forest (in decreasing order) with the unscanned part of the rope is equal to the rope being balanced. 2) All trees in the forest are balanced, i.e. [forest.(n)] is empty or [length forest.(n) >= min_length.(n)]. 3) [height forest.(n) <= n] *) (* Add the rope [r] (usually a leaf) to the appropriate slot of [forest] (according to [length r]) gathering ropes from lower levels if necessary. Assume [r] is not empty. *) let add_nonempty_to_forest forest r = let len = length r in let n = ref 0 in let sum = ref empty in (* forest.(n-1) ^ ... ^ (forest.(2) ^ (forest.(1) ^ forest.(0))) with [n] s.t. [min_length.(n) < len <= min_length.(n+1)]. [n] is at most [max_height-1] because [min_length.(max_height) = max_int] *) while len > min_length.(!n + 1) do if is_not_empty forest.(!n) then ( sum := balance_concat forest.(!n) !sum; forest.(!n) <- empty; ); if !n = level_flatten then sum := flatten !sum; incr n done; (* Height of [sum] at most 1 greater than what would be required for balance. *) sum := balance_concat !sum r; (* If [height r <= !n - 1] (e.g. if [r] is a leaf), then [!sum] is now balanced -- distinguish whether forest.(!n - 1) is empty or not (see the cited paper pp. 1319-1320). We now continue concatenating ropes until the result fits into an empty slot of the [forest]. *) let sum_len = ref(length !sum) in while !n < max_height && !sum_len >= min_length.(!n) do if is_not_empty forest.(!n) then ( sum := balance_concat forest.(!n) !sum; sum_len := length forest.(!n) + !sum_len; forest.(!n) <- empty; ); if !n = level_flatten then sum := flatten !sum; incr n done; decr n; forest.(!n) <- !sum let add_to_forest forest r = if is_not_empty r then add_nonempty_to_forest forest r (* Add a NON-EMPTY rope [r] to the forest *) let rec balance_insert forest rope = match rope with | Sub(s, i0, len) -> (* If the length of the leaf is small w.r.t. the length of [s], extract it to avoid keeping a ref the larger [s]. *) if 25 * len <= String.length s then add_nonempty_to_forest forest (Sub(String.sub s i0 len, 0, len)) else add_nonempty_to_forest forest rope | Concat(h, len, l,_, r) -> (* FIXME: when to rebalance subtrees *) if h >= max_height || len < min_length.(h) then ( (* sub-rope needs rebalancing *) balance_insert forest l; balance_insert forest r; ) else add_nonempty_to_forest forest rope ;; let concat_forest forest = let concat (n, sum) r = let sum = balance_concat r sum in (n+1, if n = level_flatten then flatten sum else sum) in snd(Array.fold_left concat (0,empty) forest) let balance = function | Sub(s, i0, len) as r -> if 0 < len && len <= extract_sub_length then Sub(String.sub s i0 len, 0, len) else r | r -> let forest = Array.make max_height empty in balance_insert forest r; concat_forest forest (* Only rebalance on the height. Also doing it when [length r < min_length.(height r)] ask for too many balancing and thus is slower. *) let balance_if_needed r = if height r >= rebalancing_height then balance r else r (** "Fast" concat for ropes. ********************************************************************** * Since concat is one of the few ways a rope can be constructed, it * must be fast. Also, this means it is this concat which is * responsible for the height of small ropes (until balance kicks in * but the later the better). *) exception Relocation_failure (* Internal exception *) (* Try to relocate the [leaf] at a position that will not increase the height. [length(relocate_topright rope leaf _)= length rope + length leaf] [height(relocate_topright rope leaf _) = height rope] *) let rec relocate_topright rope leaf len_leaf = match rope with | Sub(_,_,_) -> raise Relocation_failure | Concat(h, len, l,ll, r) -> let hr = height r + 1 in if hr < h then (* Success, we can insert the leaf here without increasing the height *) let lr = length r in Concat(h, len + len_leaf, l,ll, Concat(hr, lr + len_leaf, r, lr, leaf)) else (* Try at the next level *) Concat(h, len + len_leaf, l,ll, relocate_topright r leaf len_leaf) let rec relocate_topleft leaf len_leaf rope = match rope with | Sub(_,_,_) -> raise Relocation_failure | Concat(h, len, l,ll, r) -> let hl = height l + 1 in if hl < h then (* Success, we can insert the leaf here without increasing the height *) let len_left = len_leaf + ll in let left = Concat(hl, len_left, leaf, len_leaf, l) in Concat(h, len_leaf + len, left, len_left, r) else (* Try at the next level *) let left = relocate_topleft leaf len_leaf l in Concat(h, len_leaf + len, left, len_leaf + ll, r) (* We avoid copying too much -- as this may slow down access, even if height is lower. *) let concat2_nonempty rope1 rope2 = match rope1, rope2 with | Sub(s1,i1,len1), Sub(s2,i2,len2) -> let len = len1 + len2 in if len <= small_rope_length then let s = Bytes.create len in Bytes.blit_string s1 i1 s 0 len1; Bytes.blit_string s2 i2 s len1 len2; Sub(Bytes.unsafe_to_string s, 0, len) else Concat(1, len, rope1, len1, rope2) | Concat(h1, len1, l1,ll1, (Sub(s1, i1, lens1) as leaf1)), _ when h1 > height rope2 -> let len2 = length rope2 in let len = len1 + len2 and lens = lens1 + len2 in if lens <= small_rope_length then let s = Bytes.create lens in Bytes.blit_string s1 i1 s 0 lens1; copy_to_subbytes s lens1 rope2; Concat(h1, len, l1,ll1, Sub(Bytes.unsafe_to_string s, 0, lens)) else begin try let left = relocate_topright l1 leaf1 lens1 in (* [h1 = height l1 + 1] since the right branch is a leaf and [height l1 = height left]. *) Concat(max h1 (1 + height rope2), len, left, len1, rope2) with Relocation_failure -> let h2plus1 = height rope2 + 1 in (* if replacing [leaf1] will increase the height or if further concat will have an opportunity to add to a (small) leaf *) if (h1 = h2plus1 && len2 <= max_flatten_length) || len2 < small_rope_length then Concat(h1 + 1, len, rope1, len1, flatten rope2) else (* [h1 > h2 + 1] *) let right = Concat(h2plus1, lens, leaf1, lens1, rope2) in Concat(h1, len, l1, ll1, right) end | _, Concat(h2, len2, (Sub(s2, i2, lens2) as leaf2),_, r2) when height rope1 < h2 -> let len1 = length rope1 in let len = len1 + len2 and lens = len1 + lens2 in if lens <= small_rope_length then let s = Bytes.create lens in copy_to_subbytes s 0 rope1; Bytes.blit_string s2 i2 s len1 lens2; Concat(h2, len, Sub(Bytes.unsafe_to_string s, 0, lens), lens, r2) else begin try let right = relocate_topleft leaf2 lens2 r2 in (* [h2 = height r2 + 1] since the left branch is a leaf and [height r2 = height right]. *) Concat(max (1 + height rope1) h2, len, rope1, len1, right) with Relocation_failure -> let h1plus1 = height rope1 + 1 in (* if replacing [leaf2] will increase the height or if further concat will have an opportunity to add to a (small) leaf *) if (h1plus1 = h2 && len1 <= max_flatten_length) || len1 < small_rope_length then Concat(h2 + 1, len, flatten rope1, len1, rope2) else (* [h1 + 1 < h2] *) let left = Concat(h1plus1, lens, rope1, len1, leaf2) in Concat(h2, len, left, lens, r2) end | _, _ -> let len1 = length rope1 and len2 = length rope2 in let len = len1 + len2 in (* Small unbalanced ropes may happen if one concat left, then right, then left,... This costs a bit of time but is a good defense. *) if len <= small_rope_length then let s = Bytes.create len in copy_to_subbytes s 0 rope1; copy_to_subbytes s len1 rope2; Sub(Bytes.unsafe_to_string s, 0, len) else begin let rope1 = if len1 <= small_rope_length then flatten rope1 else rope1 and rope2 = if len2 <= small_rope_length then flatten rope2 else rope2 in let h = 1 + max (height rope1) (height rope2) in Concat(h, len1 + len2, rope1, len1, rope2) end ;; let concat2 rope1 rope2 = let len1 = length rope1 and len2 = length rope2 in let len = len1 + len2 in if len1 = 0 then rope2 else if len2 = 0 then rope1 else begin if len < len1 (* overflow *) then failwith "Rope.concat2: the length of the resulting rope exceeds max_int"; let h = 1 + max (height rope1) (height rope2) in if h >= rebalancing_height then (* We will need to rebalance anyway, so do a simple concat *) balance (Concat(h, len, rope1, len1, rope2)) else (* No automatic rebalancing -- experimentally lead to faster exec *) concat2_nonempty rope1 rope2 end ;; (** Subrope ***********************************************************************) (** [sub_to_substring flat j i len r] copies the subrope of [r] starting at character [i] and of length [len] to [flat.[j ..]]. *) let rec sub_to_substring flat j i len = function | Sub(s, i0, _) -> Bytes.blit_string s (i0 + i) flat j len | Concat(_, _, l, ll, r) -> let ri = i - ll in if ri >= 0 then (* only right branch *) sub_to_substring flat j ri len r else (* ri < 0 *) let lenr = ri + len in if lenr <= 0 then (* only left branch *) sub_to_substring flat j i len l else ( (* at least one char from the left and right branches *) sub_to_substring flat j i (-ri) l; sub_to_substring flat (j - ri) 0 lenr r; ) let flatten_subrope rope i len = assert(len <= Sys.max_string_length); let flat = Bytes.create len in sub_to_substring flat 0 i len rope; Sub(Bytes.unsafe_to_string flat, 0, len) ;; (* Are lazy sub-rope nodes really needed? *) (* This function assumes that [i], [len] define a valid sub-rope of the last arg. *) let rec sub_rec i len = function | Sub(s, i0, lens) -> assert(i >= 0 && i <= lens - len); Sub(s, i0 + i, len) | Concat(_, rope_len, l, ll, r) -> let rl = rope_len - ll in let ri = i - ll in if ri >= 0 then if len = rl then r (* => ri = 0 -- full right sub-rope *) else sub_rec ri len r else let rlen = ri + len (* = i + len - ll *) in if rlen <= 0 then (* right sub-rope empty *) if len = ll then l (* => i = 0 -- full left sub-rope *) else sub_rec i len l else (* at least one char from the left and right sub-ropes *) let l' = if i = 0 then l else sub_rec i (-ri) l and r' = if rlen = rl then r else sub_rec 0 rlen r in let h = 1 + max (height l') (height r') in (* FIXME: do we have to use this opportunity to flatten some subtrees? In any case, the height of tree we get is no worse than the initial tree (but the length may be much smaller). *) Concat(h, len, l', -ri, r') let sub rope i len = let len_rope = length rope in if i < 0 || len < 0 || i > len_rope - len then invalid_arg "Rope.sub" else if len = 0 then empty else if len <= max_flatten_length && len_rope >= 32768 then (* The benefit of flattening such subropes (and constants) has been seen experimentally. It is not clear what the "exact" rule should be. *) flatten_subrope rope i len else sub_rec i len rope (** String alike functions ***********************************************************************) let is_space = function | ' ' | '\012' | '\n' | '\r' | '\t' -> true | _ -> false let rec trim_left = function | Sub(s, i0, len) -> let i = ref i0 in let i_max = i0 + len in while !i < i_max && is_space (String.unsafe_get s !i) do incr i done; if !i = i_max then empty else Sub(s, !i, i_max - !i) | Concat(_, _, l, _, r) -> let l = trim_left l in if is_empty l then trim_left r else let ll = length l in Concat(1 + max (height l) (height r), ll + length r, l, ll, r) let rec trim_right = function | Sub(s, i0, len) -> let i = ref (i0 + len - 1) in while !i >= i0 && is_space (String.unsafe_get s !i) do decr i done; if !i < i0 then empty else Sub(s, i0, !i - i0 + 1) | Concat(_, _, l, ll, r) -> let r = trim_right r in if is_empty r then trim_right l else let lr = length r in Concat(1 + max (height l) (height r), ll + lr, l, ll, r) let trim r = trim_right(trim_left r) (* Escape the range s.[i0 .. i0+len-1]. Modeled after Bytes.escaped *) let escaped_sub s i0 len = let n = ref 0 in let i1 = i0 + len - 1 in for i = i0 to i1 do n := !n + (match String.unsafe_get s i with | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 | ' ' .. '~' -> 1 | _ -> 4) done; if !n = len then Sub(s, i0, len) else ( let s' = Bytes.create !n in n := 0; for i = i0 to i1 do (match String.unsafe_get s i with | ('\"' | '\\') as c -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c | '\n' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' | '\t' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' | '\r' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' | '\b' -> Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' | (' ' .. '~') as c -> Bytes.unsafe_set s' !n c | c -> let a = Char.code c in Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n (Char.chr (48 + a / 100)); incr n; Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); incr n; Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10)); ); incr n done; Sub(Bytes.unsafe_to_string s', 0, !n) ) let rec escaped = function | Sub(s, i0, len) -> escaped_sub s i0 len | Concat(h, _, l, _, r) -> let l = escaped l in let ll = length l in let r = escaped r in Concat(h, ll + length r, l, ll, r) (* Return the index of [c] in [s.[i .. i1-1]] plus the [offset] or [-1] if not found. *) let rec index_string offset s i i1 c = if i >= i1 then -1 else if s.[i] = c then offset + i else index_string offset s (i+1) i1 c;; (* Return the index of [c] from position [i] in the rope or a negative value if not found *) let rec unsafe_index offset i c = function | Sub(s, i0, len) -> index_string (offset - i0) s (i0 + i) (i0 + len) c | Concat(_, _, l,ll, r) -> if i >= ll then unsafe_index (offset + ll) (i - ll) c r else let li = unsafe_index offset i c l in if li >= 0 then li else unsafe_index (offset + ll) 0 c r let index_from r i c = if i < 0 || i >= length r then invalid_arg "Rope.index_from" else let j = unsafe_index 0 i c r in if j >= 0 then j else raise Not_found let index_from_opt r i c = if i < 0 || i >= length r then invalid_arg "Rope.index_from_opt"; let j = unsafe_index 0 i c r in if j >= 0 then Some j else None let index r c = let j = unsafe_index 0 0 c r in if j >= 0 then j else raise Not_found let index_opt r c = let j = unsafe_index 0 0 c r in if j >= 0 then Some j else None let contains_from r i c = if i < 0 || i >= length r then invalid_arg "Rope.contains_from" else unsafe_index 0 i c r >= 0 let contains r c = unsafe_index 0 0 c r >= 0 (* Return the index of [c] in [s.[i0 .. i]] (starting from the right) plus the [offset] or [-1] if not found. *) let rec rindex_string offset s i0 i c = if i < i0 then -1 else if s.[i] = c then offset + i else rindex_string offset s i0 (i - 1) c let rec unsafe_rindex offset i c = function | Sub(s, i0, _) -> rindex_string (offset - i0) s i0 (i0 + i) c | Concat(_, _, l,ll, r) -> if i < ll then unsafe_rindex offset i c l else let ri = unsafe_rindex (offset + ll) (i - ll) c r in if ri >= 0 then ri else unsafe_rindex offset (ll - 1) c l let rindex_from r i c = if i < 0 || i > length r then invalid_arg "Rope.rindex_from" else let j = unsafe_rindex 0 i c r in if j >= 0 then j else raise Not_found let rindex_from_opt r i c = if i < 0 || i > length r then invalid_arg "Rope.rindex_from_opt"; let j = unsafe_rindex 0 i c r in if j >= 0 then Some j else None let rindex r c = let j = unsafe_rindex 0 (length r - 1) c r in if j >= 0 then j else raise Not_found let rindex_opt r c = let j = unsafe_rindex 0 (length r - 1) c r in if j >= 0 then Some j else None let rcontains_from r i c = if i < 0 || i >= length r then invalid_arg "Rope.rcontains_from" else unsafe_rindex 0 i c r >= 0 (* Modified let lowercase_ascii r = map ~f:Char.lowercase_ascii r let uppercase_ascii r = map ~f:Char.uppercase_ascii r let lowercase = lowercase_ascii let uppercase = uppercase_ascii *) let rec map1 f = function | Concat(h, len, l, ll, r) -> Concat(h, len, map1 f l, ll, r) | Sub(s, i0, len) -> if len = 0 then empty else begin let s' = Bytes.create len in Bytes.set s' 0 (f (String.unsafe_get s i0)); Bytes.blit_string s (i0 + 1) s' 1 (len - 1); Sub(Bytes.unsafe_to_string s', 0, len) end (* Modified let capitalize_ascii r = map1 Char.uppercase_ascii r let uncapitalize_ascii r = map1 Char.lowercase_ascii r let capitalize = capitalize_ascii let uncapitalize = uncapitalize_ascii *) (** Iterator ***********************************************************************) module Iterator = struct type t = { rope: rope; len: int; (* = length rope; avoids to recompute it again and again for bound checks *) mutable i: int; (* current position in the rope; it is always a valid position of the rope or [-1]. *) mutable path: (rope * int) list; (* path to the current leaf with global range. First elements are closer to the leaf, last element is the full rope. *) mutable current: string; (* local cache of current leaf *) mutable current_g0: int; (* global index of the beginning of current string. i0 = current_g0 + offset *) mutable current_g1: int; (* global index of the char past the current string. len = current_g1 - current_g0 *) mutable current_offset: int; (* = i0 - current_g0 *) } (* [g0] is the global index (of [itr.rope]) of the beginning of the node we are examining. [i] is the _local_ index (of the current node) that we seek the leaf for *) let rec set_current_for_index_rec itr g0 i = function | Sub(s, i0, len) -> assert(0 <= i && i < len); itr.current <- s; itr.current_g0 <- g0; itr.current_g1 <- g0 + len; itr.current_offset <- i0 - g0 | Concat(_, _, l,ll, r) -> if i < ll then set_current_for_index_rec itr g0 i l else set_current_for_index_rec itr (g0 + ll) (i - ll) r let set_current_for_index itr = set_current_for_index_rec itr 0 itr.i itr.rope let rope itr = itr.rope let make r i0 = let len = length r in let itr = { rope = balance_if_needed r; len = len; i = i0; path = [(r, 0)]; (* the whole rope *) current = ""; current_offset = 0; current_g0 = 0; current_g1 = 0; (* empty range, important if [current] not set! *) } in if i0 >= 0 && i0 < len then set_current_for_index itr; (* force [current] to be set *) itr let peek itr i = if i < 0 || i >= itr.len then raise(Out_of_bounds "Rope.Iterator.peek") else ( if itr.current_g0 <= i && i < itr.current_g1 then itr.current.[i + itr.current_offset] else get itr.rope i (* rope get *) ) let get itr = let i = itr.i in if i < 0 || i >= itr.len then raise(Out_of_bounds "Rope.Iterator.get") else ( if i < itr.current_g0 || i >= itr.current_g1 then set_current_for_index itr; (* out of local bounds *) itr.current.[i + itr.current_offset] ) let pos itr = itr.i let incr itr = itr.i <- itr.i + 1 let decr itr = itr.i <- itr.i - 1 let goto itr j = itr.i <- j let move itr k = itr.i <- itr.i + k end (** (In)equality ***********************************************************************) exception Less exception Greater let compare r1 r2 = let len1 = length r1 and len2 = length r2 in let i1 = Iterator.make r1 0 and i2 = Iterator.make r2 0 in try for _i = 1 to min len1 len2 do (* on the common portion of [r1] and [r2] *) let c1 = Iterator.get i1 and c2 = Iterator.get i2 in if c1 < c2 then raise Less; if c1 > c2 then raise Greater; Iterator.incr i1; Iterator.incr i2; done; (* The strings are equal on their common portion, the shorter one is the smaller. *) compare (len1: int) len2 with | Less -> -1 | Greater -> 1 ;; (* Semantically equivalent to [compare r1 r2 = 0] but specialized implementation for speed. *) let equal r1 r2 = let len1 = length r1 and len2 = length r2 in if len1 <> len2 then false else ( let i1 = Iterator.make r1 0 and i2 = Iterator.make r2 0 in try for _i = 1 to len1 do (* len1 times *) if Iterator.get i1 <> Iterator.get i2 then raise Exit; Iterator.incr i1; Iterator.incr i2; done; true with Exit -> false ) (** KMP search algo ***********************************************************************) let init_next p = let m = String.length p in let next = Array.make m 0 in let i = ref 1 and j = ref 0 in while !i < m - 1 do if p.[!i] = p.[!j] then begin incr i; incr j; next.(!i) <- !j end else if !j = 0 then begin incr i; next.(!i) <- 0 end else j := next.(!j) done; next let search_forward_string p = if String.length p > Sys.max_array_length then failwith "Rope.search_forward: string to search too long"; let next = init_next p and m = String.length p in fun rope i0 -> let i = Iterator.make rope i0 and j = ref 0 in (try (* The iterator will raise an exception of we go beyond the length of the rope. *) while !j < m do if p.[!j] = Iterator.get i then begin Iterator.incr i; incr j end else if !j = 0 then Iterator.incr i else j := next.(!j) done; with Out_of_bounds _ -> ()); if !j >= m then Iterator.pos i - m else raise Not_found (** Buffer ***********************************************************************) module Buffer = struct (* The content of the buffer consists of the forest concatenated in decreasing order plus (at the end) the part stored in [buf]: [forest.(max_height-1) ^ ... ^ forest.(1) ^ forest.(0) ^ String.sub buf 0 pos] *) type t = { mutable buf: Bytes.t; buf_len: int; (* = String.length buf; must be > 0 *) mutable pos: int; mutable length: int; (* the length of the rope contained in this buffer -- including the part in the forest *) forest: rope array; (* keeping the partial rope in a forest will ensure it is balanced at the end. *) } (* We will not allocate big buffers, if we exceed the buffer length, we will cut into small chunks and add it directly to the forest. *) let create n = let n = if n < 1 then small_rope_length else if n > Sys.max_string_length then Sys.max_string_length else n in { buf = Bytes.create n; buf_len = n; pos = 0; length = 0; forest = Array.make max_height empty; } let clear b = b.pos <- 0; b.length <- 0; Array.fill b.forest 0 max_height empty (* [reset] is no different from [clear] because we do not grow the buffer. *) let reset b = clear b let add_char b c = if b.length = max_int then failwith "Rope.Buffer.add_char: \ buffer length will exceed the int range"; if b.pos >= b.buf_len then ( (* Buffer full, add it to the forest and allocate a new one: *) add_nonempty_to_forest b.forest (Sub(Bytes.unsafe_to_string b.buf, 0, b.buf_len)); b.buf <- Bytes.create b.buf_len; Bytes.set b.buf 0 c; b.pos <- 1; ) else ( Bytes.set b.buf b.pos c; b.pos <- b.pos + 1; ); b.length <- b.length + 1 let unsafe_add_substring b s ofs len = (* Beware of int overflow *) if b.length > max_int - len then failwith "Rope.Buffer.add_substring: \ buffer length will exceed the int range"; let buf_left = b.buf_len - b.pos in if len <= buf_left then ( (* Enough space in [buf] to hold the substring of [s]. *) String.blit s ofs b.buf b.pos len; b.pos <- b.pos + len; ) else ( (* Complete [buf] and add it to the forest: *) Bytes.blit_string s ofs b.buf b.pos buf_left; add_nonempty_to_forest b.forest (Sub(Bytes.unsafe_to_string b.buf, 0, b.buf_len)); b.buf <- Bytes.create b.buf_len; b.pos <- 0; (* Add the remaining of [s] to to forest (it is already balanced by of_substring, so we add is as such): *) let s = unsafe_of_substring s (ofs + buf_left) (len - buf_left) in add_nonempty_to_forest b.forest s ); b.length <- b.length + len let add_substring b s ofs len = if ofs < 0 || len < 0 || ofs > String.length s - len then invalid_arg "Rope.Buffer.add_substring"; unsafe_add_substring b s ofs len let add_string b s = unsafe_add_substring b s 0 (String.length s) let add_rope b (r: rope) = if is_not_empty r then ( let len = length r in if b.length > max_int - len then failwith "Rope.Buffer.add_rope: \ buffer length will exceed the int range"; (* First add the part hold by [buf]: *) add_to_forest b.forest (Sub(Bytes.sub_string b.buf 0 b.pos, 0, b.pos)); b.pos <- 0; (* I thought [balance_insert b.forest r] was going to rebalance [r] taking into account the content already in the buffer but it does not seem faster. We take the decision to possibly rebalance when the content is asked. *) add_nonempty_to_forest b.forest r; (* [r] not empty *) b.length <- b.length + len ) ;; let add_buffer b b2 = if b.length > max_int - b2.length then failwith "Rope.Buffer.add_buffer: \ buffer length will exceed the int range"; add_to_forest b.forest (Sub(Bytes.sub_string b.buf 0 b.pos, 0, b.pos)); b.pos <- 0; let forest = b.forest in let forest2 = b2.forest in for i = Array.length b2.forest - 1 to 0 do add_to_forest forest forest2.(i) done; b.length <- b.length + b2.length ;; let add_channel b ic len = if b.length > max_int - len then failwith "Rope.Buffer.add_channel: \ buffer length will exceed the int range"; let buf_left = b.buf_len - b.pos in if len <= buf_left then ( (* Enough space in [buf] to hold the input from the channel. *) really_input ic b.buf b.pos len; b.pos <- b.pos + len; ) else ( (* [len > buf_left]. Complete [buf] and add it to the forest: *) really_input ic b.buf b.pos buf_left; add_nonempty_to_forest b.forest (Sub(Bytes.unsafe_to_string b.buf, 0, b.buf_len)); (* Read the remaining from the channel *) let len = ref(len - buf_left) in while !len >= b.buf_len do let s = Bytes.create b.buf_len in really_input ic s 0 b.buf_len; add_nonempty_to_forest b.forest (Sub(Bytes.unsafe_to_string s, 0, b.buf_len)); len := !len - b.buf_len; done; (* [!len < b.buf_len] to read, put them into a new [buf]: *) let s = Bytes.create b.buf_len in really_input ic s 0 !len; b.buf <- s; b.pos <- !len; ); b.length <- b.length + len ;; (* Search for the nth element in [forest.(i ..)] of total length [len] *) let rec nth_forest forest k i len = assert(k <= Array.length forest); let r = forest.(k) in (* possibly empty *) let ofs = len - length r in (* offset of [r] in the full rope *) if i >= ofs then get r (i - ofs) else nth_forest forest (k + 1) i ofs let nth b i = if i < 0 || i >= b.length then raise(Out_of_bounds "Rope.Buffer.nth"); let forest_len = b.length - b.pos in if i >= forest_len then Bytes.get b.buf (i - forest_len) else nth_forest b.forest 0 i forest_len ;; (* Return a rope, [buf] must be duplicated as it becomes part of the rope, thus we duplicate it as ropes are immutable. What we do is very close to [add_nonempty_to_forest] followed by [concat_forest] except that we do not modify the forest and we select a sub-rope. Assume [len > 0] -- and [i0 >= 0]. *) let unsafe_sub (b: t) i0 len = let i1 = i0 + len in (* 1 char past subrope *) let forest_len = b.length - b.pos in let buf_i1 = i1 - forest_len in if buf_i1 >= len then (* The subrope is entirely in [buf] *) Sub(Bytes.sub_string b.buf (i0 - forest_len) len, 0, len) else begin let n = ref 0 in let sum = ref empty in if buf_i1 > 0 then ( (* At least one char in [buf] and at least one in the forest. Concat the ropes of inferior length and append the part of [buf] *) let rem_len = len - buf_i1 in while buf_i1 > min_length.(!n + 1) && length !sum < rem_len do sum := balance_concat b.forest.(!n) !sum; if !n = level_flatten then sum := flatten !sum; incr n done; sum := balance_concat !sum (Sub(Bytes.sub_string b.buf 0 buf_i1, 0, buf_i1)) ) else ( (* Subrope in the forest. Skip the forest elements until the last chunk of the sub-rope is found. Since [0 < len <= forest_len], there exists a nonempty rope in the forest. *) let j = ref buf_i1 in (* <= 0 *) while !j <= 0 do j := !j + length b.forest.(!n); incr n done; sum := sub b.forest.(!n - 1) 0 !j (* init. with proper subrope *) ); (* Add more forest elements until we get at least the desired length *) while length !sum < len do assert(!n < max_height); sum := balance_concat b.forest.(!n) !sum; (* FIXME: Check how this line may generate a 1Mb leaf: *) (* if !n = level_flatten then sum := flatten !sum; *) incr n done; let extra = length !sum - len in if extra = 0 then !sum else sub !sum extra len end let sub b i len = if i < 0 || len < 0 || i > b.length - len then invalid_arg "Rope.Buffer.sub"; if len = 0 then empty else (unsafe_sub b i len) let contents b = if b.length = 0 then empty else (unsafe_sub b 0 b.length) let length b = b.length end (* Using the Buffer module should be more efficient than sucessive concatenations and ensures that the final rope is balanced. *) let concat sep = function | [] -> empty | r0 :: tl -> let b = Buffer.create 1 in (* [buf] will not be used as we add ropes *) Buffer.add_rope b r0; List.iter (fun r -> Buffer.add_rope b sep; Buffer.add_rope b r) tl; Buffer.contents b (* Modified *) (** Input/output -- modeled on Pervasive ***********************************************************************) (* Imported from pervasives.ml: *) let rec output_string fh = function | Sub(s, i0, len) -> output fh (Bytes.unsafe_of_string s) i0 len | Concat(_, _, l,_, r) -> output_string fh l; output_string fh r ;; let output_rope = output_string let print_string rope = output_string stdout rope let print_endline rope = output_string stdout rope; print_newline() let prerr_string rope = output_string stderr rope let prerr_endline rope = output_string stderr rope; prerr_newline() (**/**) let rec number_leaves = function | Sub(_,_,_) -> 1 | Concat(_,_, l,_, r) -> number_leaves l + number_leaves r let rec number_concat = function | Sub(_,_,_) -> 0 | Concat(_,_, l,_, r) -> 1 + number_concat l + number_concat r let rec length_leaves = function | Sub(_,_, len) -> (len, len) | Concat(_,_, l,_, r) -> let (min1,max1) = length_leaves l and (min2,max2) = length_leaves r in (min min1 min2, max max1 max2) module IMap = Map.Make(struct type t = int let compare = Pervasives.compare end) let distrib_leaves = let rec add_leaves m = function | Sub(_,_,len) -> (try incr(IMap.find len !m) with _ -> m := IMap.add len (ref 1) !m) | Concat(_,_, l,_, r) -> add_leaves m l; add_leaves m r in fun r -> let m = ref(IMap.empty) in add_leaves m r; !m (**/**) (** Toplevel ***********************************************************************) module Rope_toploop = struct open Format let max_display_length = ref 400 (* When displaying, truncate strings that are longer than this. *) let ellipsis = ref "..." (* ellipsis for ropes longer than max_display_length. User changeable. *) (* Return [max_len - length r]. *) let rec printer_lim max_len (fm:formatter) r = if max_len > 0 then match r with | Concat(_,_, l,_, r) -> let to_be_printed = printer_lim max_len fm l in printer_lim to_be_printed fm r | Sub(s, i0, len) -> let l = if len < max_len then len else max_len in (match escaped_sub s i0 l with | Sub (s, i0, len) -> if i0 = 0 && len = String.length s then pp_print_string fm s else for i = i0 to i0 + len - 1 do pp_print_char fm (String.unsafe_get s i) done | Concat _ -> assert false); max_len - len else max_len let printer fm r = pp_print_string fm "\""; let to_be_printed = printer_lim !max_display_length fm r in pp_print_string fm "\""; if to_be_printed < 0 then pp_print_string fm !ellipsis end (** Regexp ***********************************************************************) module Regexp = struct (* FIXME: See also http://www.pps.jussieu.fr/~vouillon/ who is writing a DFA-based regular expression library. Would be nice to cooperate. *) end ;; (* Local Variables: *) (* compile-command: "make -k -C.." *) (* End: *) ================================================ FILE: src/cross-platform/wrapBn.ml ================================================ #if BSB_BACKEND = "js" then type t = Bn.t let to_string_in_hexa = Bn.toString ~base:16 let string_of_big_int = Bn.toString ~base:10 let big_int_of_string = Bn.fromString ~base:10 let hex_to_big_int h = Bn.fromString ~base:16 h let eq_big_int = Bn.eq let big_int_of_int x = x |> float_of_int |> Bn.fromFloat let zero_big_int = Bn.fromFloat 0. let unit_big_int = Bn.fromFloat 1. let sub_big_int a b = Bn.sub b a #else include WrapBnNative #end ================================================ FILE: src/cross-platform/wrapBnNative.ml ================================================ type t = Big_int.big_int let to_string_in_hexa = BatBig_int.to_string_in_hexa let string_of_big_int = Big_int.string_of_big_int let big_int_of_string = Big_int.big_int_of_string let hex_to_big_int h = Big_int.big_int_of_string ("0x"^h) let eq_big_int = Big_int.eq_big_int let big_int_of_int = Big_int.big_int_of_int let zero_big_int = Big_int.zero_big_int let unit_big_int = Big_int.unit_big_int let sub_big_int = Big_int.sub_big_int ================================================ FILE: src/cross-platform/wrapCryptokit.ml ================================================ #if BSB_BACKEND = "js" then (* TODO: Create keccak BuckleScript bindings as a separate module *) type keccakInit type keccakUpdated type keccakDigested (* Copied from https://github.com/ethereum/web3.js/blob/3547be3d1f274f70074b9eb69c3324228fc50ea5/lib/utils/utils.js#L128-L141 *) (* It can be imported after we have BuckleScript bindings to web3.js *) let toAscii: string -> string = [%raw {| function(hex) { // Find termination var str = ""; var i = 0, l = hex.length; if (hex.substring(0, 2) === '0x') { i = 2; } for (; i < l; i+=2) { var code = parseInt(hex.substr(i, 2), 16); str += String.fromCharCode(code); } return str; } |}] external create_keccak_hash : string -> keccakInit = "keccak"[@@bs.module ] external update : string -> keccakUpdated = ""[@@bs.send.pipe :keccakInit] external digest : string -> string = ""[@@bs.send.pipe :keccakUpdated] let string_keccak str = create_keccak_hash "keccak256" |> update str |> digest "hex" let hex_keccak str = create_keccak_hash "keccak256" |> update (toAscii str) |> digest "hex" #else include WrapCryptokitNative #end ================================================ FILE: src/cross-platform/wrapCryptokitNative.ml ================================================ module Hash = Cryptokit.Hash let string_keccak str : string = let sha3_256 = Hash.keccak 256 in let () = sha3_256#add_string str in let ret = sha3_256#result in let tr = Cryptokit.Hexa.encode () in let () = tr#put_string ret in let () = tr#finish in let ret = tr#get_string in (* need to convert ret into hex *) ret let strip_0x h = if BatString.starts_with h "0x" then BatString.tail h 2 else h let add_hex sha3_256 h = let h = strip_0x h in let add_byte c = sha3_256#add_char c in let chars = BatString.explode h in let rec work chars = match chars with | [] -> () | [x] -> failwith "odd-length hex" | a :: b :: rest -> let () = add_byte (Hex.to_char a b) in work rest in work chars let hex_keccak h : string = let sha3_256 = Hash.keccak 256 in let () = add_hex sha3_256 h in let ret = sha3_256#result in let tr = Cryptokit.Hexa.encode () in let () = tr#put_string ret in let () = tr#finish in let ret = tr#get_string in (* need to convert ret into hex *) ret ================================================ FILE: src/cross-platform/wrapList.ml ================================================ #if BSB_BACKEND = "js" then let range i j = let rec aux n acc = if n < i then acc else aux (n - 1) (n :: acc) in aux j [] let sum l = let rec s rest acc = match rest with | [] -> acc | h::t -> s t (acc + h) in s l 0 let filter_map f l = let maybeAddHead filter head list = match filter head with | ((Some (v))[@explicit_arity ]) -> v :: list | None -> list in let rec s rest acc = match rest with | [] -> List.rev acc | h::t -> s t (maybeAddHead f h acc) in s l [] let rec last = function | [] -> invalid_arg "Empty List" | x::[] -> x | _::t -> last t (* Copied from *) type 'a mut_list = { hd: 'a; mutable tl: 'a list;} external inj : 'a mut_list -> 'a list = "%identity" module Acc = struct let dummy () = { hd = (Obj.magic ()); tl = [] } let create x = { hd = x; tl = [] } let accum acc x = let cell = create x in acc.tl <- inj cell; cell end let unique ?(eq= (=)) l = let rec loop dst = function | [] -> () | h::t -> (match List.exists (eq h) t with | true -> loop dst t | false -> loop (Acc.accum dst h) t) in let dummy = Acc.dummy () in loop dummy l; dummy.tl;; #else include WrapListNative #end ================================================ FILE: src/cross-platform/wrapListNative.ml ================================================ let range i j = BatList.(range i `To j) let sum = BatList.sum let filter_map = BatList.filter_map let last = BatList.last let unique = BatList.unique ================================================ FILE: src/cross-platform/wrapOption.ml ================================================ #if BSB_BACKEND = "js" then include Js.Option (* Js.Option.map expects the callback to be uncurried https://bucklescript.github.io/bucklescript/api/Js.Option.html#VALmap Explanation: https://bucklescript.github.io/docs/en/function.html#curry-uncurry *) let map a = Js.Option.map ((fun x -> a x)[@bs]) #else include BatOption #end ================================================ FILE: src/cross-platform/wrapString.ml ================================================ #if BSB_BACKEND = "js" then let starts_with = Js.String.startsWith #else include WrapStringNative #end ================================================ FILE: src/cross-platform/wrapStringNative.ml ================================================ let starts_with = BatString.starts_with ================================================ FILE: src/cross-platform-for-ocamlbuild/META ================================================ # OASIS_START # DO NOT EDIT (digest: ee11ff5ab0dcdc3283bfdeea5feb58b8) version = "0.0.03" description = "A compiler targeting Ethereum Virtual Machine" requires = "batteries rope cryptokit hex" archive(byte) = "cross-platform.cma" archive(byte, plugin) = "cross-platform.cma" archive(native) = "cross-platform.cmxa" archive(native, plugin) = "cross-platform.cmxs" exists_if = "cross-platform.cma" # OASIS_STOP ================================================ FILE: src/cross-platform-for-ocamlbuild/cross-platform.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: 5f3e3f97fec314fba146c24e67ee5ea3) WrapBn WrapCryptokit WrapList WrapString WrapOption # OASIS_STOP ================================================ FILE: src/cross-platform-for-ocamlbuild/cross-platform.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: 5f3e3f97fec314fba146c24e67ee5ea3) WrapBn WrapCryptokit WrapList WrapString WrapOption # OASIS_STOP ================================================ FILE: src/cross-platform-for-ocamlbuild/wrapOption.ml ================================================ include BatOption ================================================ FILE: src/exec/bamboo.ml ================================================ open Lexer open Lexing open Printf open Syntax open Codegen (* The following two functions comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) let print_position outx lexbuf = let pos = lexbuf.lex_curr_p in fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) let parse_with_error lexbuf = try Parser.file Lexer.read lexbuf with | SyntaxError msg -> fprintf stderr "%a: %s\n" print_position lexbuf msg; exit (-1) | Parser.Error -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) | _ -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) let abi_option = BatOptParse.StdOpt.store_true () let optparser : BatOptParse.OptParser.t = BatOptParse.OptParser.make ~version:"0.0.03" ~usage:"bamboo [options] < src.bbo" ~description:"By default, bamboo compiles the source from stdin and prints EVM bytecode in stdout. Do not trust the output as the compiler still contains bugs probably." () let () = let () = BatOptParse.OptParser.add optparser ~long_names:["abi"] ~help:"print the ABI interface in JSON" abi_option in let files = BatOptParse.OptParser.parse_argv optparser in let () = if files <> [] then (Printf.eprintf "This compiler accepts input from stdin.\n"; exit 1) in let abi : bool = (Some true = abi_option.BatOptParse.Opt.option_get ()) in let lexbuf = Lexing.from_channel stdin in let toplevels : unit Syntax.toplevel list = parse_with_error lexbuf in let toplevels = Assoc.list_to_contract_id_assoc toplevels in let toplevels : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc = Type.assign_types toplevels in let contracts = Assoc.filter_map (fun x -> match x with | Contract c -> Some c | _ -> None) toplevels in let () = match contracts with | [] -> () | _ -> let constructors : constructor_compiled Assoc.contract_id_assoc = compile_constructors contracts in let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let layout = LayoutInfo.construct_layout_info contracts_layout_info in let runtime_compiled = compile_runtime layout contracts in let bytecode : WrapBn.t Evm.program = compose_bytecode constructors runtime_compiled (fst (List.hd contracts)) in let () = if abi then Ethereum.print_abi toplevels else Evm.print_imm_program bytecode in () in () ================================================ FILE: src/exec/compileFile.ml ================================================ open Codegen let compile_file (file : string) : string = BatFile.with_file_in file (fun channel -> let lexbuf = BatLexing.from_input channel in let contracts : unit Syntax.toplevel list = Parse.parse_with_error lexbuf in let contracts = Assoc.list_to_contract_id_assoc contracts in let contracts : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc = Type.assign_types contracts in let contracts = Assoc.filter_map (fun x -> match x with Syntax.Contract c -> Some c | _ -> None) contracts in let constructors : constructor_compiled Assoc.contract_id_assoc = compile_constructors contracts in let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let layout = LayoutInfo.construct_layout_info contracts_layout_info in let runtime_compiled = compile_runtime layout contracts in let bytecode = compose_bytecode constructors runtime_compiled (fst (List.hd contracts)) in Evm.string_of_imm_program bytecode) ================================================ FILE: src/exec/compileFile.mli ================================================ (** [compile_file filename] compiles the source of filename into a constructor bytecode *) val compile_file : string -> string ================================================ FILE: src/exec/endToEnd.ml ================================================ (* below is largely based on ocaml-rpc *) (* * Copyright (c) 2006-2009 Citrix Systems Inc. * Copyright (c) 2006-2014 Thomas Gazagnaire * * Permission to use, copy, modify, and distribute this software for any * purpose with or without fee is hereby granted, provided that the above * copyright notice and this permission notice appear in all copies. * * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) (* Yoichi Hirai: I modified the above-mentinoed code. *) exception Connection_reset let lib_version = "0.1.1" module Utils = struct let open_connection_unix_fd filename = let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in try let addr = Unix.ADDR_UNIX(filename) in Unix.connect s addr; Printf.eprintf "connected \n%!"; s with e -> Printf.eprintf "some problem \n%!"; Unix.close s; raise e let minisleep (sec: float) = ignore (Unix.select [] [] [] sec) end type connection = | Unix_socket of string let string_of_call ?(version=Jsonrpc.V1) (call : Rpc.call) = let c = call in Rpc.(Jsonrpc. (let json = match version with | V1 -> Dict [ "method", String ((c : Rpc.call).name); "params", Enum c.params; "id", Int (new_id ()); ] | V2 -> Dict [ "jsonrpc", String "2.0"; "method", String c.name; "params", Rpc.Enum c.params; "id", Int (new_id ()); ] in to_string json)) let string_of_rpc_call (call : Rpc.call) = string_of_call ~version:(Jsonrpc.V2) call let rpc_response_of_fd fd = Jsonrpc.response_of_in_channel (Unix.in_channel_of_descr fd) let send_call ~fd call = let body = string_of_rpc_call call in let output_string str = ignore (Unix.write fd (Bytes.of_string str) 0 (String.length str)) in output_string body let rpc_fd (fd: Unix.file_descr) call = try send_call ~fd call; rpc_response_of_fd fd with Unix.Unix_error(Unix.ECONNRESET, _, _) -> raise Connection_reset let with_fd s ~call = try let result = rpc_fd s call in result with e -> raise e let do_rpc_unix s call = with_fd s ~call let eth_accounts_call : Rpc.call = Rpc.({ name = "eth_accounts" ; params = [] }) (* How to perform a call and expect a return of eth_accounts *) let filename = "/tmp/test/geth.ipc" type address = string [@@deriving rpc] type eth_accounts = address list [@@deriving rpc] type eth_transaction = { from : string ; _to : string [@key "to"] ; gas : string ; value : string ; data : string ; gasprice : string } [@@deriving rpc] let pick_result (j : Rpc.response) = let j = Jsonrpc.json_of_response Jsonrpc.V2 j in Rpc. (match j with | Dict x -> begin try List.assoc "result" x with Not_found -> let () = Printf.eprintf "got response %s\n%!" (Rpc.string_of_rpc j) in raise Not_found end | _ -> failwith "unexpected form" ) let eth_accounts s : eth_accounts = let res : Rpc.response = (do_rpc_unix s eth_accounts_call) in let json : Rpc.t = pick_result res in let result : eth_accounts = eth_accounts_of_rpc json in result let init_code_dummy = "0x00" let eth_sendTransaction s (trans : eth_transaction) : address = let call : Rpc.call = Rpc.({ name = "eth_sendTransaction" ; params = [rpc_of_eth_transaction trans] }) in let res : Rpc.response = do_rpc_unix s call in let json : Rpc.t = pick_result res in let result = address_of_rpc json in result let eth_call s (trans : eth_transaction) : string = let c : Rpc.call = Rpc.({ name = "eth_call" ; params = [rpc_of_eth_transaction trans; Rpc.rpc_of_string "latest"] }) in let res : Rpc.response = do_rpc_unix s c in let json = pick_result res in Rpc.string_of_rpc json let test_mineBlocks s (num : int) = let call : Rpc.call = Rpc.({ name = "test_mineBlocks" ; params = [Rpc.Int (Int64.of_int num)] }) in let () = ignore (pick_result (do_rpc_unix s call)) in () let test_rawSign s (addr : address) (data : string) = let call : Rpc.call = Rpc.({ name = "test_rawSign" ; params = [rpc_of_address addr; rpc_of_string data] }) in let res = do_rpc_unix s call in let json = pick_result res in Rpc.string_of_rpc json let eth_getBalance s (addr : address) : WrapBn.t = let call : Rpc.call = Rpc.({ name = "eth_getBalance" ; params = [rpc_of_address addr; Rpc.rpc_of_string "latest"] }) in let res : Rpc.response = do_rpc_unix s call in let json = pick_result res in let () = Printf.printf "got result %s\n%!" (Rpc.string_of_rpc json) in let result = Rpc.string_of_rpc json in Big_int.big_int_of_string result let test_setChainParams s (config : Rpc.t) : unit = let call : Rpc.call = Rpc.({ name = "test_setChainParams" ; params = [config] }) in ignore (do_rpc_unix s call) let rich_config (accounts : address list) : Rpc.t = let accounts_with_balance = List.map (fun addr -> (addr, Rpc.(Dict [ ("wei", String "0x100000000000000000000000000000000000000000") ]))) accounts in Rpc.(Dict [ ("sealEngine", String "NoProof") ; ("params", Dict [ ("accountStartNonce", String "0x") ; ("maximumExtraDataSize", String "0x1000000") ; ("blockReward", String "0x") ; ("allowFutureBlocks", String "1") ; ("homesteadForkBlock", String "0x00") ; ("EIP150ForkBlock", String "0x00") ; ("EIP158ForkBlock", String "0x00") ; ("constantinopleForkBlock", String "0xffffffffffffffffffff") ]) ; ("genesis", Dict [ ("author", String "0000000000000010000000000000000000000000") ; ("timestamp", String "0x00") ; ("parentHash", String "0x0000000000000000000000000000000000000000000000000000000000000000") ; ("extraData", String "0x") ; ("gasLimit", String "0x1000000000000") ]) ; ("accounts", Dict accounts_with_balance) ] ) type log = { topics : string list } [@@ deriving rpc] type transaction_receipt = { blockHash : string ; blockNumber : int64 ; transactionHash : string ; transactionIndex : int64 ; cumulativeGasUsed : int64 ; gasUsed : int64 ; contractAddress : address ; logs : log list } [@@ deriving rpc] let eth_getTransactionReceipt s (tx : string) : transaction_receipt = let call : Rpc.call = { Rpc.name = "eth_getTransactionReceipt" ; Rpc.params = [Rpc.rpc_of_string tx] } in let res : Rpc.response = do_rpc_unix s call in let json : Rpc.t = pick_result res in let result = transaction_receipt_of_rpc json in result let eth_blockNumber s : int64 = let call : Rpc.call = Rpc.({ name = "eth_blockNumber" ; params = [] }) in let res : Rpc.response = do_rpc_unix s call in let json = pick_result res in let result = Rpc.int64_of_rpc json in result let eth_getCode s addr : string = let call : Rpc.call = Rpc.({ name = "eth_getCode" ; params = [rpc_of_address addr; rpc_of_string "latest"] }) in let res : Rpc.response = do_rpc_unix s call in let json = pick_result res in let result = Rpc.string_of_rpc json in result let test_rewindToBlock s = let call = Rpc.({ name = "test_rewindToBlock" ; params = [Rpc.Int (Int64.of_int 0)] }) in ignore (do_rpc_unix s call) let personal_newAccount s = let call = Rpc.({ name = "personal_newAccount" ; params = [rpc_of_string ""] }) in let ret = do_rpc_unix s call in let json = pick_result ret in address_of_rpc json let personal_unlockAccount s addr = let call = Rpc.({ name = "personal_unlockAccount" ; params = [rpc_of_address addr; rpc_of_string ""; rpc_of_int 100000] }) in ignore (do_rpc_unix s call) let eth_getStorageAt s addr slot = let call = Rpc.({ name = "eth_getStorageAt" ; params = [rpc_of_address addr; rpc_of_string (WrapBn.string_of_big_int slot); rpc_of_string "latest"] }) in let ret = do_rpc_unix s call in let json = pick_result ret in Big_int.big_int_of_string (Rpc.string_of_rpc json) let wait_till_mined s old_block = while eth_blockNumber s = old_block do Utils.minisleep 0.01 done let sample_file_name : string = "./src/parse/examples/006auction_first_case.bbo" let advance_block s = let old_blk = eth_blockNumber s in let () = test_mineBlocks s 1 in let () = wait_till_mined s old_blk in () let reset_chain s acc = (* Maybe it's not necessary to create a new account every time *) let my_acc = match acc with | None -> personal_newAccount s | Some acc -> acc in let config = rich_config [my_acc] in let () = test_setChainParams s config in let () = test_rewindToBlock s in let () = test_rewindToBlock s in let balance = eth_getBalance s my_acc in let () = assert (Big_int.gt_big_int balance (Big_int.big_int_of_int 10000000000000000)) in my_acc let deploy_code s my_acc code value = let trans : eth_transaction = { from = my_acc ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = value ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" ; data = code ; _to = "0x" } in let tx = (eth_sendTransaction s trans) in let () = advance_block s in let receipt = eth_getTransactionReceipt s tx in receipt let call s tr = let tx = eth_sendTransaction s tr in let () = advance_block s in eth_getTransactionReceipt s tx let testing_006 s my_acc = let initcode_compiled : string = CompileFile.compile_file sample_file_name in let initcode_args : string = "0000000000000000000000000000000000000000000000000000000000000000" ^ "0000000000000000000000000000000000000000000000000000000400000020" ^ "0000000000000000000000000000000000000000000000000000000000000000" in let initcode = initcode_compiled^initcode_args in let receipt = deploy_code s my_acc initcode "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let original = eth_getStorageAt s contract_address (Big_int.big_int_of_int 4) in let () = assert (Big_int.(eq_big_int original zero_big_int)) in let tr : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "100" ; data = "" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call s tr in let n = eth_getStorageAt s contract_address (Big_int.big_int_of_int 4) in let () = Printf.printf "got storage %s\n" (WrapBn.string_of_big_int n) in let () = assert (Big_int.(eq_big_int n (big_int_of_int 100))) in () let constructor_arg_test s = let initcode_compiled : string = CompileFile.compile_file sample_file_name in let initcode_args : string = "0000000000000000000000000000000000000000000000000000000000000000" ^ "0000000000000000000000000000000000000000000000000000000000000000" in let initcode = initcode_compiled^initcode_args in let my_acc = reset_chain s None in let receipt = deploy_code s my_acc initcode "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (not (String.length deployed > 2)) in let () = Printf.printf "didn't find code! good!\n" in my_acc let testing_00bb s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00bbauction_first_named_case.bbo" in let initcode_args : string = "0000000000000000000000000000000000000000000000000000000000000000" in let initcode = initcode_compiled^initcode_args in let receipt = deploy_code s my_acc initcode "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code! %s\n" deployed in let storage_first_word = eth_getStorageAt s contract_address (Big_int.big_int_of_int 0) in let () = Printf.printf "first word! %s\n" (WrapBn.string_of_big_int storage_first_word) in let original = eth_getStorageAt s contract_address (Big_int.big_int_of_int 4) in let () = assert (Big_int.(eq_big_int original zero_big_int)) in let tr : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "100" ; data = Ethereum.compute_signature_hash "bid()" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call s tr in let () = Printf.printf "used gas: %s\n%!" (Int64.to_string receipt.gasUsed) in let () = Printf.printf "transaction hash: %s\n%!" receipt.transactionHash in let n = eth_getStorageAt s contract_address (Big_int.big_int_of_int 2) in let () = assert (Big_int.(eq_big_int n (big_int_of_int 100))) in () (* showing not quite satisfactory results *) let testing_00b s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00b_auction_more.bbo" in let initcode_args : string = "0000000000000000000000000000000000000000000000000000000000000000" ^ "ff00000000000000000000000000000000000000000000000000000400000020" ^ "0000000000000000000000000000000000000000000000000000000000000000" in let initcode = initcode_compiled^initcode_args in let receipt = deploy_code s my_acc initcode "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let highest_bid : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = Ethereum.compute_signature_hash "highest_bid()" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s highest_bid in let () = Printf.printf "got answer: %s\n%!" answer in let tr : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "100" ; data = Ethereum.compute_signature_hash "bid()" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call s tr in let answer = eth_call s highest_bid in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000064") in () let testing_010 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/010_logical_and.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let both : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(bool,bool)") ^ "0000000000000000000000000000000000000000000000000000000005f5e1000000000000000000000000000000000000000000000000000000000005f5e100" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s both in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000001") in () let testing_011 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/011_keccak256.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let both : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(address,bytes32)") ^ "0000000000000000000000000000000000000000000000000000000005f5e1000000000000000000000000000000000000000000000000000000000005f5e100" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s both in let () = Printf.printf "got answer: %s\n%!" answer in let expectation = "0x" ^ (Ethereum.hex_keccak "0x0000000000000000000000000000000005f5e1000000000000000000000000000000000000000000000000000000000005f5e100") in let () = Printf.printf "expectation: %s\n%!" expectation in let () = assert (answer = expectation) in () let random_ecdsa s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00e_ecdsarecover.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert(String.length deployed > 2) in (* XXX the procedure so far can be factored out *) let random_req : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = "0x" ^ (Ethereum.compute_signature_hash "a(bytes32,uint8,bytes32,bytes32)") ^ "0000000000000000000000000000000000000000000000000000000005f5e100"^ "0000000000000000000000000000000000000000000000000000000005f5e100"^ "0000000000000000000000000000000000000000000000000000000005f5e100"^ "0000000000000000000000000000000000000000000000000000000005f5e100" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s random_req in let () = Printf.printf "got answer: %s\n" answer in let tx = eth_sendTransaction s random_req in let () = advance_block s in let () = Printf.printf "transaction id for random_eq: %s\n%!" tx in let () = assert(answer = "0x0000000000000000000000000000000000000000000000000000000000000000") in () let correct_ecdsa s my_acc = (* The input data and the output data are cited from Parity:builtin.rs from commit * 3308c404400a2bc58b12489814e9f3cfd5c9d272 *) let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00e_ecdsarecover.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert(String.length deployed > 2) in (* XXX the procedure so far can be factored out *) let random_req : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = "0x" ^ (Ethereum.compute_signature_hash "a(bytes32,uint8,bytes32,bytes32)") ^ "47173285a8d7341e5e972fc677286384f802f8ef42a5ec5f03bbfa254cb01fad000000000000000000000000000000000000000000000000000000000000001b650acf9d3f5f0a2c799776a1254355d5f4061762a237396a99a0e0e3fc2bcd6729514a0dacb2e623ac4abd157cb18163ff942280db4d5caad66ddf941ba12e03" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s random_req in let () = Printf.printf "got answer: %s\n" answer in let tx = eth_sendTransaction s random_req in let () = advance_block s in let () = Printf.printf "transaction id for random_eq: %s\n%!" tx in let () = assert(answer = "0x000000000000000000000000c08b5542d177ac6686946920409741463a15dddb") in () let zero_word = "0000000000000000000000000000000000000000000000000000000000000000" let one_word = "0000000000000000000000000000000000000000000000000000000000000001" let testing_00i s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00i_local_bool.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(uint8)") ^ zero_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s c in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x" ^ one_word) in () let testing_013 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/013_iszero.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "a(bytes32)") ^ zero_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s c in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000001") in () let zero_word = "0000000000000000000000000000000000000000000000000000000000000000" let one_word = "0000000000000000000000000000000000000000000000000000000000000001" let testing_022 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/022_plus_gt.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(uint256,uint256,uint256)") ^ one_word ^ one_word ^ zero_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s c in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000000") in () let testing_014 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/014_ifelse.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(bool,bool)") ^ zero_word ^ one_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call s c in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x" ^ zero_word) in () let testing_016 s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/016_void.bbo" in let receipt = deploy_code s my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "300" ; data = (Ethereum.compute_signature_hash "pass(address,uint256)") ^ "000000000000000000000000000000000000000000000000000000000000aaaa" ^ "0000000000000000000000000000000000000000000000000000000000000001" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let tx = eth_sendTransaction s c in let () = advance_block s in let balance = eth_getBalance s "0x000000000000000000000000000000000000aaaa" in let () = assert (Big_int.(eq_big_int balance (big_int_of_int 1))) in () let pad_to_word str = let str = WrapCryptokit.strip_0x str in let len = String.length str in let () = assert (len <= 64) in let padded = 64 - len in let pad = BatString.make padded '0' in pad ^ str let testing_00h_timeout s my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00h_payment_channel.bbo" in let sender = pad_to_word (WrapCryptokit.strip_0x my_acc) in let recipient = pad_to_word (WrapCryptokit.strip_0x my_acc) in let startDate = "0000000000000000000000000000000000000000000000000000000000010000" in let endDate = "0000000000000000000000000000000000000000000000000000000000020000" in let initdata = initcode_compiled ^ sender ^ recipient ^ startDate ^ endDate in let receipt = deploy_code s my_acc initdata "300" in let contract_address = receipt.contractAddress in let deployed = eth_getCode s contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let balance = eth_getBalance s contract_address in let () = assert (Big_int.(eq_big_int balance (big_int_of_int 300))) in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = Ethereum.compute_signature_hash "ChannelTimeOut()" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call s c in let () = Printf.printf "timeout tx: %s\n%!" receipt.transactionHash in let balance = eth_getBalance s contract_address in let () = assert (Big_int.(eq_big_int balance zero_big_int)) in () let testing_00h_early channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/00h_payment_channel.bbo" in let sender = pad_to_word (WrapCryptokit.strip_0x my_acc) in let recv = personal_newAccount channel in let recipient = pad_to_word (WrapCryptokit.strip_0x recv) in (* give receiver some Ether so that she can send transactions *) let c : eth_transaction = { from = my_acc ; _to = recv ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "1000000000000000000000000" ; data = "0x00" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let () = ignore (call channel c) in let startDate = "0000000000000000000000000000000000000000000000000000000000010000" in let endDate = "0000000000000000000000000000000000000100000000000000000000020000" in let initdata = initcode_compiled ^ sender ^ recipient ^ startDate ^ endDate in let receipt = deploy_code channel my_acc initdata "0x3000000000" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let balance = eth_getBalance channel contract_address in let () = assert (Big_int.(eq_big_int balance (big_int_of_string "0x3000000000"))) in let value = "0000000000000000000000000000000000000000000000000000002000000000" in let concatenation = (WrapCryptokit.strip_0x contract_address) ^ value in let () = Printf.printf "concatenation: %s\n" concatenation in let hash = Ethereum.hex_keccak concatenation in let () = Printf.printf "hash: %s\n" hash in (* first call *) let sign = test_rawSign channel recv hash in let () = Printf.printf "sign: %s\n" sign in let sign = BatString.tail sign 2 in let r = BatString.sub sign 0 64 in let s = BatString.sub sign 64 64 in let v = "00000000000000000000000000000000000000000000000000000000000000" ^ (BatString.sub sign 128 2) in let () = Printf.printf "v: %s\n" v in let c : eth_transaction = { from = recv ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = "0x" ^ Ethereum.compute_signature_hash "CloseChannel(bytes32,uint8,bytes32,bytes32,uint256)" ^ hash ^ v ^ r ^ s ^ value ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let () = Printf.printf "sent data looks like this %s\n" c.data in let () = assert (String.length c.data = (4 + 32 + 32 + 32 + 32 + 32) * 2 + 2) in let receipt = call channel c in let () = Printf.printf "timeout tx: %s\n%!" receipt.transactionHash in (* second call *) let sign = test_rawSign channel my_acc hash in let () = Printf.printf "sign: %s\n" sign in let sign = BatString.tail sign 2 in let r = BatString.sub sign 0 64 in let s = BatString.sub sign 64 64 in let v = "00000000000000000000000000000000000000000000000000000000000000" ^ (BatString.sub sign 128 2) in let c : eth_transaction = { from = recv ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = Ethereum.compute_signature_hash "CloseChannel(bytes32,uint8,bytes32,bytes32,uint256)" ^ hash ^ v ^ r ^ s ^ value ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel c in let () = Printf.printf "timeout tx: %s\n%!" receipt.transactionHash in (* need to do a bit more *) let balance = eth_getBalance channel contract_address in let () = assert (Big_int.(eq_big_int balance zero_big_int)) in let recv_balance = eth_getBalance channel recv in let () = assert (Big_int.(gt_big_int recv_balance (big_int_of_string "0x2000000000"))) in () let zero_word = "0000000000000000000000000000000000000000000000000000000000000000" let one_word = "0000000000000000000000000000000000000000000000000000000000000001" let testing_mapmap_non_interference channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/018_mapmap.bbo" in let receipt = deploy_code channel my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let write_to_true : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "set(bool,address,bool)")^ one_word ^ zero_word ^ one_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel write_to_true in let () = Printf.printf "write tx: %s\n" receipt.transactionHash in let read_from_true : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "get(bool,address)") ^ one_word ^ zero_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel read_from_true in let receipt = call channel read_from_true in let () = Printf.printf "read tx: %s\n" receipt.transactionHash in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000001") in let read_from_false : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "get(bool,address)") ^ zero_word ^ zero_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel read_from_false in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x0000000000000000000000000000000000000000000000000000000000000000") in () let testing_019 channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/019_something.bbo" in let initdata = initcode_compiled ^ "00000000000000000000000000000000000000000000000000005af3107a4000" ^ (pad_to_word (WrapCryptokit.strip_0x my_acc)) in let receipt = deploy_code channel my_acc initdata "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let initial_trans : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = "0x" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel initial_trans in let ask_my_balance : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "balanceOf(address)")^(pad_to_word (WrapCryptokit.strip_0x my_acc)) ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel ask_my_balance in let () = assert (answer = "0x00000000000000000000000000000000000000000000000000005af3107a4000") in let () = Printf.printf "balance match!\n" in () let testing_land_neq channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/021_land_neq.bbo" in let receipt = deploy_code channel my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let initial_trans : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f()") ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel initial_trans in let () = Printf.printf "got answer %s\n%!" answer in let () = assert (answer = "0x" ^ one_word) in () let testing_01a channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/01a_event.bbo" in let receipt = deploy_code channel my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let write_to_true : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "e(uint256)")^one_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel write_to_true in let () = assert (List.length receipt.logs = 1) in let log = List.hd receipt.logs in let () = assert (List.length log.topics = 2) in () let test_plus_mult channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/020_plus_mult.bbo" in let receipt = deploy_code channel my_acc initcode_compiled "0" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let one_word = "0000000000000000000000000000000000000000000000000000000000000001" in let two_word = "0000000000000000000000000000000000000000000000000000000000000002" in let three_word = "0000000000000000000000000000000000000000000000000000000000000003" in let seven_word = "0000000000000000000000000000000000000000000000000000000000000007" in let c : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "f(uint256,uint256,uint256)")^one_word^two_word^three_word ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel c in let () = assert (answer = "0x" ^ seven_word) in () (* takes an address in hex (0x followed by 40 characters) form and returns it as a word (64 characters without 0x) *) let address_as_word address = let () = assert (String.length address = 42) in let () = assert (String.sub address 0 2 = "0x") in (String.make 24 '0') ^ (String.sub address 2 40) let testing_024 channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/024_vault_shorter.bbo" in let recover_key = my_acc in let () = Printf.printf "recover: %s\n" recover_key in let vault_key = personal_newAccount channel in let () = Printf.printf "vault: %s\n" vault_key in let hot = personal_newAccount channel in let () = Printf.printf "hot: %s\n" hot in let c : eth_transaction = { from = my_acc ; _to = vault_key ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "2200000000000000000" ; data = "0x00" ; gasprice = "0x0000000000000000000000000000000000000000000000000000005af3107a40" } in let () = ignore (call channel c) in let c : eth_transaction = { from = my_acc ; _to = hot ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "2200000000000000000" ; data = "0x00" ; gasprice = "0x0000000000000000000000000000000000000000000000000000005af3107a40" } in let () = ignore (call channel c) in let initdata = initcode_compiled ^ address_as_word vault_key ^ address_as_word recover_key in let receipt = deploy_code channel my_acc initdata "10000" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let balance = eth_getBalance channel contract_address in let () = assert (Big_int.(eq_big_int balance (big_int_of_int 10000))) in (* initiate a withdrawal *) let unvault : eth_transaction = { from = vault_key ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "unvault(uint256,address)")^ (pad_to_word "50")^(address_as_word hot) ; gasprice = "0x0000000000000000000000000000000000000000000000000000005af3107a40" } in let unvault_tx = call channel unvault in let () = Printf.printf "unvault_tx: %Ld\n" unvault_tx.blockNumber in (* wait for two seconds *) let () = Unix.sleep 2 in let () = advance_block channel in let redeem : eth_transaction = { from = hot ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "redeem()") ; gasprice = "0x0000000000000000000000000000000000000000000000000000005af3107a40" } in let redeem_tx = call channel redeem in let () = Printf.printf "redeem_tx: %Ld\n" redeem_tx.blockNumber in let balance = eth_getBalance channel hot in let () = Printf.printf "hot acccount now has %s\n%!" (WrapBn.string_of_big_int balance) in let () = assert(Big_int.(eq_big_int balance (big_int_of_string "2198885220000000080"))) in () let test_erc20 channel my_acc = let initcode_compiled : string = CompileFile.compile_file "./src/parse/examples/01b_erc20better.bbo" in let initial_amount : string = "0000000000000000000000000000000000000000000000010000000000000000" in let receipt = deploy_code channel my_acc (initcode_compiled ^ initial_amount) "100000000000000000" in let contract_address = receipt.contractAddress in let deployed = eth_getCode channel contract_address in let () = assert (String.length deployed > 2) in let () = Printf.printf "saw code!\n" in let initialize : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = "" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel initialize in let () = Printf.printf "init tx id: %s\n" receipt.transactionHash in let less_than_half_amount : string = "00000000000000000000000000000000000000000000000007f0000000000000" in let buying : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "100000000000000000" ; data = (Ethereum.compute_signature_hash "buy(uint256)")^less_than_half_amount ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel buying in let () = Printf.printf "consumed gas: %s\n" (Int64.to_string receipt.gasUsed) in let () = Printf.printf "buying tx id: %s\n" receipt.transactionHash in let check_balance : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "balanceOf(address)")^(pad_to_word (WrapCryptokit.strip_0x my_acc)) ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel check_balance in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x" ^ less_than_half_amount) in let second = personal_newAccount channel in let c : eth_transaction = { from = my_acc ; _to = second ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "1000000000000000000000000" ; data = "0x00" ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let () = ignore (call channel c) in let approve : eth_transaction = { from = my_acc ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "approve(address,uint256)")^ (pad_to_word (WrapCryptokit.strip_0x second)) ^ less_than_half_amount ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel approve in let () = Printf.printf "approve tx id: %s\n" receipt.transactionHash in let see_allowance : eth_transaction = { from = second ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "allowance(address,address)")^ (pad_to_word (WrapCryptokit.strip_0x my_acc)) ^ (pad_to_word (WrapCryptokit.strip_0x second)) ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel see_allowance in let () = assert (answer = "0x" ^ less_than_half_amount) in let use_allowance : eth_transaction = { from = second ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "transferFrom(address,address,uint256)")^ (pad_to_word (WrapCryptokit.strip_0x my_acc)) ^ (pad_to_word (WrapCryptokit.strip_0x second)) ^ less_than_half_amount ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel use_allowance in let check_balance : eth_transaction = { from = second ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "balanceOf(address)")^(pad_to_word (WrapCryptokit.strip_0x second)) ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel check_balance in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x" ^ less_than_half_amount) in let see_allowance : eth_transaction = { from = second ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "allowance(address,address)")^ (pad_to_word (WrapCryptokit.strip_0x my_acc)) ^ (pad_to_word (WrapCryptokit.strip_0x second)) ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let answer = eth_call channel see_allowance in let () = Printf.printf "got answer: %s\n%!" answer in let () = assert (answer = "0x" ^ zero_word) in let weis = "0000000000000000000000000000000000000000000000000010000000000000" in let second_orig_balance = eth_getBalance channel second in let selling : eth_transaction = { from = second ; _to = contract_address ; gas = "0x0000000000000000000000000000000000000000000000000000000005f5e100" ; value = "0" ; data = (Ethereum.compute_signature_hash "sell(uint256,uint256)")^less_than_half_amount^weis ; gasprice = "0x00000000000000000000000000000000000000000000000000005af3107a4000" } in let receipt = call channel selling in let second_new_balance = eth_getBalance channel second in let () = assert (Big_int.gt_big_int second_new_balance second_orig_balance) in let answer = eth_call channel check_balance in let () = assert (answer = "0x" ^ zero_word) in () let () = let s = Utils.open_connection_unix_fd filename in let my_acc = constructor_arg_test s in let () = testing_00h_early s my_acc in let () = testing_00h_timeout s my_acc in let () = testing_00bb s my_acc in let () = testing_006 s my_acc in let () = testing_00b s my_acc in let () = random_ecdsa s my_acc in let () = correct_ecdsa s my_acc in let () = testing_010 s my_acc in let () = testing_00i s my_acc in let () = testing_011 s my_acc in let () = testing_013 s my_acc in let () = testing_014 s my_acc in let () = testing_016 s my_acc in let () = testing_mapmap_non_interference s my_acc in let () = testing_019 s my_acc in let () = testing_01a s my_acc in let () = test_erc20 s my_acc in let () = testing_022 s my_acc in let () = testing_024 s my_acc in let () = Unix.close s in () (* ocaml-rpc formats every message as an HTTP request while geth does not expect this *) (* ocaml-bitcoin is similar. It always adds HTTP headers *) ================================================ FILE: src/exec-js/bambooJs.ml ================================================ open Lexer open Syntax open Codegen let parse_with_error lexbuf = try Parser.file Lexer.read lexbuf with | SyntaxError msg -> failwith msg | Parser.Error -> failwith "syntax error" | _ -> failwith "syntax error" let compile_file input_file = let lexbuf = Lexing.from_string input_file in let toplevels : unit Syntax.toplevel list = parse_with_error lexbuf in let toplevels = Assoc.list_to_contract_id_assoc toplevels in let toplevels : Syntax.typ Syntax.toplevel Assoc.contract_id_assoc = Type.assign_types toplevels in let contracts = Assoc.filter_map (fun x -> match x with | Contract c -> Some c | _ -> None) toplevels in let () = match contracts with | [] -> () | _ -> let constructors : constructor_compiled Assoc.contract_id_assoc = compile_constructors contracts in let contracts_layout_info : (Assoc.contract_id * LayoutInfo.contract_layout_info) list = List.map (fun (id, const) -> (id, layout_info_from_constructor_compiled const)) constructors in let layout = LayoutInfo.construct_layout_info contracts_layout_info in let runtime_compiled = compile_runtime layout contracts in let bytecode : WrapBn.t Evm.program = compose_bytecode constructors runtime_compiled (fst (List.hd contracts)) in let () = Evm.print_imm_program bytecode in () in () external resume : unit -> unit = "process.stdin.resume" [@@bs.val] external setEncoding : string -> unit = "process.stdin.setEncoding" [@@bs.val] external stdin_on_data : (_ [@bs.as "data"]) -> (string -> unit) -> unit = "process.stdin.on" [@@bs.val] let () = resume () let () = setEncoding "utf8" let () = stdin_on_data compile_file ================================================ FILE: src/lib/META ================================================ # OASIS_START # DO NOT EDIT (digest: ee03fbfcb0883e448492600c58692ce0) version = "0.0.01" description = "A compiler targetting Ethereum Virtual Machine" archive(byte) = "lib.cma" archive(byte, plugin) = "lib.cma" archive(native) = "lib.cmxa" archive(native, plugin) = "lib.cmxs" exists_if = "lib.cma" # OASIS_STOP ================================================ FILE: src/lib/lib_test.ml ================================================ let case0 = ("pay(address)", "0c11dedd") let case1_case : Syntax.usual_case_header = Syntax.( { case_return_typ = [] ; case_name = "pay" ; case_arguments = [{arg_typ = AddressType; arg_ident = "addr"; arg_location = None}] }) let case2_case : Syntax.usual_case_header = Syntax.( { case_return_typ = [Uint256Type] ; case_name = "f" ; case_arguments = [{arg_typ = Uint256Type; arg_ident = "x"; arg_location = None}] }) let case2_hash :string = "b3de648b" let _ = let () = Printf.printf "case0 %s %s\n" (Ethereum.keccak_signature (fst case0)) (snd case0) in let () = assert (Ethereum.keccak_signature (fst case0) = (snd case0)) in let () = assert (Ethereum.case_header_signature_hash case1_case = (snd case0)) in let () = assert ((Ethereum.case_header_signature_hash case2_case) = case2_hash) in let () = assert (WrapBn.eq_big_int (WrapBn.hex_to_big_int "01") WrapBn.unit_big_int) in let () = assert (Ethereum.string_keccak "" = Ethereum.hex_keccak "0x") in let () = assert (Ethereum.string_keccak "a" = Ethereum.hex_keccak "0x61") in let () = assert (Ethereum.string_keccak "ab" = Ethereum.hex_keccak "6162") in Printf.printf "lib_test: success\n" ================================================ FILE: src/parse/META ================================================ # OASIS_START # DO NOT EDIT (digest: 82d5d9184cfb0635001b4f2d55e8449d) version = "0.0.03" description = "A compiler targeting Ethereum Virtual Machine" requires = "ast menhirLib" archive(byte) = "parse.cma" archive(byte, plugin) = "parse.cma" archive(native) = "parse.cmxa" archive(native, plugin) = "parse.cmxs" exists_if = "parse.cma" # OASIS_STOP ================================================ FILE: src/parse/README.md ================================================ # a parser for the Bamboo language The basic set up is based on [Real World OCaml Chapter 16](https://realworldocaml.org/v1/en/html/parsing-with-ocamllex-and-menhir.html). ================================================ FILE: src/parse/examples/000nil.bbo ================================================ ================================================ FILE: src/parse/examples/001empty.bbo ================================================ contract C() { } ================================================ FILE: src/parse/examples/002comment.bbo ================================================ contract C() { // a comment is ignored. } ================================================ FILE: src/parse/examples/003default_abort.bbo ================================================ contract C() { default { abort; } } ================================================ FILE: src/parse/examples/004simple_case_abort.bbo ================================================ contract C() { case (uint256 f(uint256 _x, uint256 _y)) { abort; } default { abort; } } ================================================ FILE: src/parse/examples/005auction_start.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { } ================================================ FILE: src/parse/examples/006auction_first_case.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { default { return then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } } ================================================ FILE: src/parse/examples/007auction_first_case_more.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { default { _bids[_beneficiary] = true; return then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } } ================================================ FILE: src/parse/examples/008new_var.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { default { bool x = true; abort; } } ================================================ FILE: src/parse/examples/009new_var_auc.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { default { bid new_bid = deploy bid(sender(msg), value(msg), address(this)) with value(msg) reentrance { abort; }; // failure throws. _bids[sender(msg)] = true; return then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } } contract bid (address _sender ,uint256 _value ,address _auction ) { } ================================================ FILE: src/parse/examples/00a_auc_first_cast.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { default { if (now(block) > _bidding_time) return then become auction_done(_beneficiary, _bids, _highest_bid); if (value(msg) < _highest_bid) abort; bid new_bid = deploy bid(sender(msg), value(msg), this) with value(msg) reentrance { abort; }; // failure throws. _bids[sender(msg)] = true; return then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } } contract auction_done (address _bene, address => bool _bids, uint256 _highest_bid) { } contract bid (address _sender ,uint256 _value ,address _auction ) { } ================================================ FILE: src/parse/examples/00b_auction_more.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { case (bool bid()) { if (now(block) > _bidding_time) return (false) then become auction_done(_beneficiary, _bids, _highest_bid); if (value(msg) < _highest_bid) abort; bid new_bid = deploy bid(sender(msg), value(msg), this) with value(msg) reentrance { abort; }; // failure throws. _bids[address(new_bid)] = true; return (true) then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } case (uint256 highest_bid()) { return (_highest_bid) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (uint256 bidding_time()) { return (_bidding_time) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } default { abort; // cancels the call. } // When the control reaches the end of a contract block, // it causes an abort. } contract auction_done (address _bene, address => bool _bids, uint256 _highest_bid) { } contract bid (address _sender ,uint256 _value ,address _auction ) { } ================================================ FILE: src/parse/examples/00bbauction_first_named_case.bbo ================================================ contract auction (uint256 _highest_bid) { case(bool bid()) { bid new_bid = deploy bid(sender(msg)) with value(msg) reentrance { abort; }; // failure throws. return (true) then become auction(value(msg)); } } contract bid (address _sender ) { } ================================================ FILE: src/parse/examples/00c_auction.bbo ================================================ contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids ,uint256 _highest_bid) { case (bool bid()) { if (now(block) > _bidding_time) return (false) then become auction_done(_beneficiary, _bids, _highest_bid); if (value(msg) < _highest_bid) abort; bid new_bid = deploy bid(sender(msg), value(msg), this) with value(msg) reentrance { abort; }; // failure throws. _bids[address(new_bid)] = true; return (true) then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } case (uint256 highest_bid()) { return (_highest_bid) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (uint256 bidding_time()) { return (_bidding_time) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (address beneficiary()) { return (_beneficiary) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } default { abort; // cancels the call. } // When the control reaches the end of a contract block, // it causes an abort. } contract bid (address _bidder ,uint256 _value ,auction _auction) { case (bool refund()) { if (sender(msg) != _bidder) abort; if (_auction.highest_bid() reentrance { abort; } == _value) abort; selfdestruct(_bidder); } case (bool pay_beneficiary()) { if (iszero(_auction.highest_bid() reentrance { abort; })) abort; address beneficiary = _auction.beneficiary() reentrance { abort; }; selfdestruct(beneficiary); } default { abort; } } contract auction_done (address _bene, address => bool _bids, uint256 _highest_bid) { } ================================================ FILE: src/parse/examples/00d_auction.bbo ================================================ // The contract signature auction(address,uint256,bool[address],uint256) can be used as a continuation // of a contract. When the auction contract is created, bool[address] cannot be passed, // so the array is initizilly zeroed out. contract auction (address _beneficiary ,uint256 _bidding_time ,address => bool _bids /// When the contract is created, this must be empty. ,uint256 _highest_bid) { case (bool bid()) { if (now(block) > _bidding_time) return (false) then become auction_done(_beneficiary, _bids, _highest_bid); if (value(msg) < _highest_bid) abort; bid new_bid = deploy bid(sender(msg), value(msg), this) with value(msg) reentrance { abort; }; // failure throws. _bids[address(new_bid)] = true; return (true) then become auction(_beneficiary, _bidding_time, _bids, value(msg)); } case (uint256 highest_bid()) { return (_highest_bid) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (uint256 bidding_time()) { return (_bidding_time) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } case (address beneficiary()) { return (_beneficiary) then become auction(_beneficiary, _bidding_time, _bids, _highest_bid); } default { abort; // cancels the call. } // When the control reaches the end of a contract block, // it causes an abort. } contract bid (address _bidder ,uint256 _value ,auction _auction) // the compiler is aware that an `auction` account can become an `auction_done` account. { case (bool refund()) { if (sender(msg) != _bidder) abort; if (_auction.bid_is_highest(_value) reentrance { abort; }) abort; selfdestruct(_bidder); } case (bool pay_beneficiary()) { if (not _auction.bid_is_highest(_value) reentrance { abort; }) abort; address beneficiary = _auction.beneficiary() reentrance { abort; }; selfdestruct(beneficiary); } default { abort; } } contract auction_done(address _beneficiary, address => bool _bids, uint256 _highest_bid) { case (bool bid_is_highest(uint256 _cand)) { if (not _bids[sender(msg)]) abort; return (_highest_bid == _cand) then become auction_done(_beneficiary, _bids, _highest_bid); } case (address beneficiary()) { if (not _bids[sender(msg)]) abort; return (_beneficiary) then become auction_done(_beneficiary, _bids, _highest_bid); } default { abort; } } ================================================ FILE: src/parse/examples/00e_ecdsarecover.bbo ================================================ contract A() { case (address a(bytes32 x, uint8 b, bytes32 c, bytes32 d)) { return (pre_ecdsarecover(x, b, c, d)) then become A(); } } ================================================ FILE: src/parse/examples/00f_bytes32.bbo ================================================ contract A () { case(bool f(bytes32 a)) { return (true) then become A(); } } ================================================ FILE: src/parse/examples/00g_int8.bbo ================================================ contract A () { case(bool f(uint8 a)) { return (true) then become A(); } } ================================================ FILE: src/parse/examples/00h_payment_channel.bbo ================================================ // based on https://medium.com/@matthewdif/ethereum-payment-channel-in-50-lines-of-code-a94fad2704bc contract Channel ( address channelSender , address channelRecipient , uint256 startDate , uint256 endDate , bytes32 => address signatures ) { case(void CloseChannel(bytes32 h, uint8 v, bytes32 r, bytes32 s, uint256 val)) { address signer = pre_ecdsarecover(h, v, r, s); if ((signer != channelSender) && (signer != channelRecipient)) abort; bytes32 proof = keccak256(this, val); if (proof != h) abort; if (iszero(signatures[proof])) { signatures[proof] = signer; return then become Channel(channelSender, channelRecipient, startDate, endDate, signatures); } else if (signatures[proof] != signer) { void = channelRecipient.default() with val reentrance { abort; }; // failure throws. selfdestruct(channelSender); } else abort; } case(void ChannelTimeOut()) { if (endDate > now(block)) abort; selfdestruct(channelSender); } } ================================================ FILE: src/parse/examples/00i_local_bool.bbo ================================================ contract A () { case(bool f(uint8 a)) { bool x = true; return (x) then become A(); } } ================================================ FILE: src/parse/examples/010_logical_and.bbo ================================================ contract A () { case (bool f(bool a, bool b)) { return (a && b) then become A(); } } ================================================ FILE: src/parse/examples/011_keccak256.bbo ================================================ contract A() { case(bytes32 f(address a, bytes32 b)) { return(keccak256(a, b)) then become A(); } } ================================================ FILE: src/parse/examples/013_iszero.bbo ================================================ contract A () { case (bool a(bytes32 x)) { return (iszero(x)) then become A(); } } ================================================ FILE: src/parse/examples/014_ifelse.bbo ================================================ contract A () { case (bool f(bool x, bool y)) { if (x) return (true) then become A (); else if (y) { return (false) then become A (); } abort; } } ================================================ FILE: src/parse/examples/015_ifblock.bbo ================================================ contract A () { case (bool f(bool x)) { if(x) { return(true) then become A(); } abort; } } ================================================ FILE: src/parse/examples/016_void.bbo ================================================ contract A () { case(bool pass(address rec, uint256 amount)) { void = rec.default() with amount reentrance { abort; }; return (true) then become A(); } } ================================================ FILE: src/parse/examples/017_return_void.bbo ================================================ contract A () { case (void f()) { return then become A (); } } ================================================ FILE: src/parse/examples/018_mapmap.bbo ================================================ contract A(bool => address => bool mat) { case (void set(bool x, address y, bool v)) { mat[x][y] = v; return then become A(mat); } case (bool get(bool x, address y)) { return (mat[x][y]) then become A(mat); } } ================================================ FILE: src/parse/examples/019_something.bbo ================================================ contract PreToken (uint256 totalSupply ,address initialOwner ,address => uint256 balances ) { default { balances[initialOwner] = totalSupply; return then become Token(totalSupply, balances); } } contract Token (uint256 totalSupply ,address => uint256 balances) { case(uint256 totalSupply()) { return totalSupply then become Token(totalSupply, balances); } case(uint256 balanceOf(address a)) { return balances[a] then become Token(totalSupply, balances); } case(bool transfer(address _to, uint256 _value)) { if (balances[sender(msg)] < _value) abort; if (sender(msg) == _to) return true then become Token(totalSupply, balances); balances[sender(msg)] = balances[sender(msg)] - _value; if ((balances[_to] + _value) < balances[_to]) abort; balances[_to] = balances[_to] + _value; return true then become Token(totalSupply, balances); } } ================================================ FILE: src/parse/examples/01a_event.bbo ================================================ event E(uint256 indexed a); contract A () { case(void e(uint256 v)) { log E(v); return then become A(); } } ================================================ FILE: src/parse/examples/01b_erc20better.bbo ================================================ contract PreToken (uint256 totalSupply ,address => uint256 balances ,address => address => uint256 allowances ) { default { balances[this] = totalSupply; return then become Token(totalSupply, balances, allowances); } } event Transfer(address indexed _from, address indexed _to, uint256 _amount); event Buy(address indexed _buyer, uint256 _amount, uint256 _value); event Sell(address indexed _buyer, uint256 _amount, uint256 _value); event Approval(address indexed _owner, address indexed _spender, uint256 _value); contract Token (uint256 totalSupply ,address => uint256 balances ,address => address => uint256 allowances ) { case(uint256 totalSupply()) { return totalSupply then become Token(totalSupply, balances, allowances); } case(uint256 balanceOf(address a)) { return balances[a] then become Token(totalSupply, balances, allowances); } case(bool transfer(address _to, uint256 _amount)) { if (balances[sender(msg)] < _amount) abort; if (sender(msg) == _to) { log Transfer(sender(msg), sender(msg), _amount); return true then become Token(totalSupply, balances, allowances); } balances[sender(msg)] = balances[sender(msg)] - _amount; if (balances[_to] + _amount < balances[_to]) abort; balances[_to] = balances[_to] + _amount; log Transfer(sender(msg), _to, _amount); return true then become Token(totalSupply, balances, allowances); } case(bool approve(address _spender, uint256 _amount)) { if (balances[sender(msg)] < _amount) abort; if (sender(msg) == _spender) abort; allowances[sender(msg)][_spender] = _amount; log Approval(sender(msg), _spender, _amount); return true then become Token(totalSupply, balances, allowances); } case(uint256 allowance(address _owner, address _spender)) { return allowances[_owner][_spender] then become Token(totalSupply, balances, allowances); } case(bool transferFrom(address _from, address _to, uint256 _amount)) { if (balances[_from] < _amount) abort; if (allowances[_from][sender(msg)] < _amount) abort; if (_from == _to) { log Transfer(_from, _to, _amount); return true then become Token(totalSupply, balances, allowances); } balances[_from] = balances[_from] - _amount; allowances[_from][sender(msg)] = allowances[_from][sender(msg)] - _amount; balances[_to] = balances[_to] + _amount; log Transfer(_from, _to, _amount); return true then become Token(totalSupply, balances, allowances); } case(bool buy(uint256 _amount)) { if (balances[this] < _amount) abort; if (balances[sender(msg)] + _amount < balances[sender(msg)]) abort; uint256 old_eth_balance = balance(this) - value(msg); if (balance(this) * _amount > (balances[this] - _amount) * value(msg)) abort; balances[this] = balances[this] - _amount; balances[sender(msg)] = balances[sender(msg)] + _amount; log Buy(sender(msg), _amount, value(msg)); return true then become Token(totalSupply, balances, allowances); } case (bool sell(uint256 _amount, uint256 _value)) { if (balance(this) < _value) abort; if (balances[sender(msg)] < _amount) abort; if (balances[this] + _amount < balances[this]) abort; if (not (iszero(value(msg)))) abort; uint256 old_eth_balance = balance(this); uint256 new_eth_balance = balance(this) - _value; uint256 new_amount = balances[this] + _amount; if (new_eth_balance * _amount < new_amount * _value) abort; balances[this] = new_amount; balances[sender(msg)] = balances[sender(msg)] - _amount; log Sell(sender(msg), _amount, _value); void = sender(msg).default() with _value reentrance { abort; }; return true then become Token(totalSupply, balances, allowances); } } ================================================ FILE: src/parse/examples/020_plus_mult.bbo ================================================ contract A () { case (uint256 f(uint256 a, uint256 b, uint256 c)) { return a + b * c then become A(); } } ================================================ FILE: src/parse/examples/021_land_neq.bbo ================================================ contract A () { case (bool f()) { return true && false != true then become A(); } } ================================================ FILE: src/parse/examples/022_plus_gt.bbo ================================================ contract A () { case(bool f(uint256 a, uint256 b, uint256 c)) { return a + b < c then become A(); } } ================================================ FILE: src/parse/examples/024_vault.bbo ================================================ // Based on http://www.blunderingcode.com/ether-vaults/ contract Vault(address vaultKey, address recoveryKey) { case(void unvault(uint256 _amount, address _hotWallet)) { if (sender(msg) != vaultKey) abort; uint256 unvaultPeriod = 60 * 60 * 24 * 7 * 2; // two weeks if (now(block) + unvaultPeriod < now(block)) abort; return then become UnVaulting(now(block) + unvaultPeriod, _amount, _hotWallet, vaultKey, recoveryKey); } case(void destroy()) { if (sender(msg) != recoveryKey) abort; return then become Destroyed(); } default { return then become Vault(vaultKey, recoveryKey); } } contract UnVaulting(uint256 redeemtime, uint256 amount, address hotWallet, address vaultKey, address recoveryKey) { case(void redeem()) { if (amount > balance(this)) abort; void = hotWallet.default() with amount reentrance { abort; }; return then become Vault(vaultKey, recoveryKey); } case(void recover()) { if (sender(msg) != recoveryKey) abort; return then become Vault(vaultKey, recoveryKey); } case(void destroy()) { if (sender(msg) != recoveryKey) abort; return then become Destroyed(); } default { return then become UnVaulting(redeemtime, amount, hotWallet, vaultKey, recoveryKey); } } contract Destroyed() { // any call just throws; } ================================================ FILE: src/parse/examples/024_vault_shorter.bbo ================================================ // Based on http://www.blunderingcode.com/ether-vaults/ contract Vault(address vaultKey, address recoveryKey) { case(void unvault(uint256 _amount, address _hotWallet)) { if (sender(msg) != vaultKey) abort; uint256 unvaultPeriod = 2; // two seconds if (now(block) + unvaultPeriod < now(block)) abort; return then become UnVaulting(now(block) + unvaultPeriod, _amount, _hotWallet, vaultKey, recoveryKey); } case(void destroy()) { if (sender(msg) != recoveryKey) abort; return then become Destroyed(); } default { return then become Vault(vaultKey, recoveryKey); } } contract UnVaulting(uint256 redeemtime, uint256 amount, address hotWallet, address vaultKey, address recoveryKey) { case(void redeem()) { if (amount > balance(this)) abort; void = hotWallet.default() with amount reentrance { abort; }; return then become Vault(vaultKey, recoveryKey); } case(void recover()) { if (sender(msg) != recoveryKey) abort; return then become Vault(vaultKey, recoveryKey); } case(void destroy()) { if (sender(msg) != recoveryKey) abort; return then become Destroyed(); } default { return then become UnVaulting(redeemtime, amount, hotWallet, vaultKey, recoveryKey); } } contract Destroyed() { // any call just throws; } ================================================ FILE: src/parse/examples/025_declit_numeric.bbo ================================================ contract A () { case(bool f(uint256 a)) { return a < 5 then become A(); } case(uint256 g(uint256 a)) { return 1 + 9 then become A(); } case(uint256 gg(uint256 a)) { return 12138129191999999999 + 9213817283712 then become A(); } case(uint256 ggg(uint256 a)) { return 77712138129191999999999 - 9 then become A(); } case(bool s()) { return 239842934 > 289302 then become A(); } case(uint8 i(uint8 a)) { return 12u8 + 5u8 then become A(); } case(uint8 j()) { return 12u8 - 5u8 then become A(); } case(uint8 jjjj()) { return 120u8 + 255u8 then become A(); } case(bool k()) { return 12u8 > 5u8 then become A(); } case(bool q(uint8 a)) { return a < 5u8 then become A(); } case(uint8 multiply5(uint8 a)) { return a * 5u8 then become A(); } case(uint256 multiply7(uint256 a)) { return a * 7 then become A(); } } ================================================ FILE: src/parse/examples/026_abc.bbo ================================================ contract A() { case (uint256 f()) { return 0 then become B(); } } contract B() { case (uint256 f()) { return 1 then become C(); } } contract C() { case (uint256 f()) { return 2 then become A(); } } ================================================ FILE: src/parse/examples/027_counting.bbo ================================================ contract A(uint256 counter) { case (uint256 f()) { return counter then become A(counter + 1); } } ================================================ FILE: src/parse/lexer.mll ================================================ (* Some code in this file comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) { open Lexing open Parser exception SyntaxError of string } let white = [' ' '\t']+ let newline = '\r' | '\n' | "\r\n" let digit = ['0'-'9'] let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* let comment = "//" (_ # ['\r' '\n'])* newline rule read = parse | white { read lexbuf } | comment { new_line lexbuf; read lexbuf } | newline { new_line lexbuf; read lexbuf } | "contract" { CONTRACT } | "default" { DEFAULT } | "case" { CASE } | "abort" { ABORT } | "uint8" { UINT8 } | "uint256" { UINT256 } | "bytes32" { BYTES32 } | "address" { ADDRESS } | "bool" { BOOL } | "[" { LSQBR } | "]" { RSQBR } | "if" { IF } | "else" { ELSE } | "true" { TRUE } | "false" { FALSE } | "then" { THEN } | "become" { BECOME } | "return" { RETURN } | ";" { SEMICOLON } | "(" { LPAR } | ")" { RPAR } | "{" { LBRACE } | "}" { RBRACE } | "," { COMMA } | "==" { EQUALITY } | "!=" { NEQ } | "<" { LT } | ">" { GT } | "=" { SINGLE_EQ } | "deploy" { DEPLOY } | "with" { ALONG } | "reentrance" { REENTRANCE } | "selfdestruct" { SELFDESTRUCT } | "." { DOT } | "not" { NOT } | "msg" { MSG } | "value" { VALUE } | "sender" { SENDER } | "this" { THIS } | "balance" { BALANCE } | "now" { NOW } | "block" { BLOCK } | "void" { VOID } | "&&" { LAND } | "=>" { RARROW } | "+" { PLUS } | "-" { MINUS } | "*" { MULT } | "event" { EVENT } | "log" { LOG } | "indexed" { INDEXED } | digit+ as i { DECLIT256 (WrapBn.big_int_of_string i) } (* uint8 has at most three digits *) | digit digit? digit? "u8" as i { let last = String.length i - 2 in DECLIT8 (WrapBn.big_int_of_string (String.sub i 0 last)) } | id { IDENT (lexeme lexbuf) } | eof { EOF } ================================================ FILE: src/parse/negative_examples/bad_end.bbo ================================================ contract A () { default { void = sender(msg).default() reentrance { abort; }; } } ================================================ FILE: src/parse/negative_examples/duplicate_contract_names.bbo ================================================ contract C() { } contract C() { } ================================================ FILE: src/parse/negative_examples/mixed_uints.bbo ================================================ contract A () { case(bool f(uint256 a)) { return a < 5u8 then become A(); } } ================================================ FILE: src/parse/negative_examples/multi_default.bbo ================================================ contract A() { default { abort; } default { abort; } } ================================================ FILE: src/parse/negative_examples/uint256_too_big.bbo ================================================ contract A () { case(bool f(uint256 a)) { return a < 115792089237316195423570985008687907853269984665640564039457584007913129639936 then become A(); } } ================================================ FILE: src/parse/negative_examples/uint8_too_big.bbo ================================================ contract A () { case(bool f(uint8 a)) { return a < 300u8 then become A(); } } ================================================ FILE: src/parse/negative_examples/uint8_with_four_digits.bbo ================================================ contract A () { case(bool f(uint8 a)) { return a < 1029u8 then become A(); } } ================================================ FILE: src/parse/negative_examples/unknown_ctor_arg.bbo ================================================ contract A(k x) { } ================================================ FILE: src/parse/negative_examples/unknown_return.bbo ================================================ contract A() { case (xyzxyz a(bytes32 x, bytes32 b, uint8 c, bytes32 d)) { return (pre_ecdsarecover(x, b, c, d)) then become A(); } } ================================================ FILE: src/parse/negative_examples/unknown_type.bbo ================================================ contract unknown () { case(bool f(xyz k)) { return (true) then become unknown(); } } ================================================ FILE: src/parse/negative_examples/void_not_void.bbo ================================================ contract A () { default { void = sender(msg); abort; } } ================================================ FILE: src/parse/negative_examples/void_some_return.bbo ================================================ contract A () { case (void f(address a)) { return (a) then become A (); } } ================================================ FILE: src/parse/negative_examples/wrong_arg.bbo ================================================ contract A() { case (address a(uint8 x, uint8 b, bytes32 c, bytes32 d)) { return (pre_ecdsarecover(x, b, c, d)) then become A(); } } ================================================ FILE: src/parse/negative_examples/wrong_return.bbo ================================================ contract A () { case(bool f(uint256 x)) { return x then become A(); } } ================================================ FILE: src/parse/parse.mldylib ================================================ # OASIS_START # DO NOT EDIT (digest: c99c8065d9a0587b2171ca8644cac62d) Lexer # OASIS_STOP ================================================ FILE: src/parse/parse.mllib ================================================ # OASIS_START # DO NOT EDIT (digest: c99c8065d9a0587b2171ca8644cac62d) Lexer # OASIS_STOP ================================================ FILE: src/parse/parser.mly ================================================ %token CONTRACT %token IDENT %token DECLIT256 %token DECLIT8 %token ADDRESS %token UINT256 %token UINT8 %token BYTES32 %token BOOL %token LPAR %token RPAR %token PLUS %token MINUS %token MULT %token RARROW %token COMMA %token LSQBR %token RSQBR %token LBRACE %token RBRACE %token DOT %token CASE %token DEFAULT %token IF %token ELSE %token RETURN %token FALSE %token TRUE %token THEN %token BECOME %token SEMICOLON %token EQUALITY %token NEQ %token LT %token GT %token SINGLE_EQ %token EVENT %token LOG %token DEPLOY %token ALONG %token REENTRANCE %token ABORT %token SELFDESTRUCT %token NOT %token VALUE %token SENDER %token MSG %token THIS %token LAND %token NOW %token VOID %token BLOCK %token INDEXED %token BALANCE %token EOF %right RARROW %left LAND %left NEQ EQUALITY LT GT %left PLUS MINUS %left MULT %start file %% %inline plist(X): xs = delimited(LPAR, separated_list(COMMA, X), RPAR) {xs} file: | cs = list(contract); EOF; { cs } ; contract: | CONTRACT; name = IDENT; args = plist(arg); LBRACE; css = list(case); RBRACE; { Syntax.Contract ({ Syntax.contract_cases = css ; contract_name = name ; contract_arguments = args}) } | EVENT; name = IDENT; args = plist(event_arg); SEMICOLON; { Syntax.Event { Syntax.event_arguments = args ; event_name = name }} ; case: | ch = case_header; cb = block; { { Syntax.case_header = ch ; Syntax.case_body = cb } } ; block: | LBRACE; scs = list(sentence); RBRACE { scs } ; case_header: | DEFAULT { Syntax.DefaultCaseHeader } | CASE; LPAR; return_typ = typ; name = IDENT; args = plist(arg); RPAR { Syntax.UsualCaseHeader { case_return_typ = [return_typ] (* multi returns not supported *) ; Syntax.case_name = name ; case_arguments = args } } | CASE; LPAR; VOID; name = IDENT; args = plist(arg); RPAR { Syntax.UsualCaseHeader { case_return_typ = [] ; Syntax.case_name = name ; case_arguments = args } } ; arg: | t = typ; i = IDENT { { Syntax.arg_typ = t ; Syntax.arg_ident = i ; Syntax.arg_location = None } } ; event_arg: | a = arg { Syntax.event_arg_of_arg a false } | t = typ; INDEXED; i = IDENT { { Syntax.event_arg_body = { Syntax.arg_typ = t ; Syntax.arg_ident = i ; Syntax.arg_location = None } ; Syntax.event_arg_indexed = true } } ; typ: | UINT256 { Syntax.Uint256Type } | UINT8 { Syntax.Uint8Type } | BYTES32 { Syntax.Bytes32Type } | ADDRESS { Syntax.AddressType } | BOOL { Syntax.BoolType } | key = typ; RARROW; value = typ; { Syntax.MappingType (key, value) } | s = IDENT { Syntax.ContractInstanceType s } ; %inline body: | s = sentence {[s]} | b = block {b} ; sentence: | ABORT; SEMICOLON { Syntax.AbortSentence } | RETURN; value = option(exp); THEN; BECOME; cont = exp; SEMICOLON { Syntax.ReturnSentence { Syntax. return_exp = value; return_cont = cont} } | lhs = lexp; SINGLE_EQ; rhs = exp; SEMICOLON { Syntax.AssignmentSentence (lhs, rhs) } | t = typ; name = IDENT; SINGLE_EQ; value = exp; SEMICOLON { Syntax.VariableInitSentence { Syntax.variable_init_type = t ; variable_init_name = name ; variable_init_value = value } } | VOID; SINGLE_EQ; value = exp; SEMICOLON { Syntax.ExpSentence value } | IF; LPAR; cond = exp; RPAR; bodyT = body; ELSE; bodyF = body { Syntax.IfThenElse (cond, bodyT, bodyF) } | IF; LPAR; cond = exp; RPAR; body = body { Syntax.IfThenOnly (cond, body) } | LOG; name = IDENT; lst = exp_list; SEMICOLON { Syntax.LogSentence (name, lst, None)} | SELFDESTRUCT; e = exp; SEMICOLON { Syntax.SelfdestructSentence e } ; %inline op: | PLUS {fun (l, r) -> Syntax.PlusExp(l, r)} | MINUS {fun (l, r) -> Syntax.MinusExp(l, r)} | MULT {fun (l, r) -> Syntax.MultExp(l, r)} | LT {fun (l, r) -> Syntax.LtExp(l, r)} | GT {fun (l, r) -> Syntax.GtExp(l, r)} | NEQ {fun (l, r) -> Syntax.NeqExp(l, r)} | EQUALITY {fun (l, r) -> Syntax.EqualityExp(l, r)} ; exp: | lhs = exp; LAND; rhs = exp { Syntax.LandExp (lhs, rhs), () } | TRUE { Syntax.TrueExp, () } | FALSE { Syntax.FalseExp, () } | d = DECLIT256 { Syntax.DecLit256Exp d, ()} | d = DECLIT8 { Syntax.DecLit8Exp d, ()} | VALUE LPAR MSG RPAR { Syntax.ValueExp, () } | SENDER LPAR MSG RPAR { Syntax.SenderExp, () } | BALANCE; LPAR; e = exp; RPAR { Syntax.BalanceExp e, () } | NOW LPAR BLOCK RPAR { Syntax.NowExp, () } | lhs = exp; o = op; rhs = exp { (o (lhs, rhs)), () } | s = IDENT { Syntax.IdentifierExp s, () } | LPAR; e = exp; RPAR { Syntax.ParenthExp e, () } | s = IDENT; lst = exp_list { Syntax.FunctionCallExp {Syntax.call_head = s; call_args = lst }, () } | DEPLOY; s = IDENT; lst = exp_list; m = msg_info { Syntax.NewExp { Syntax.new_head = s; new_args = lst; new_msg_info = m }, () } | contr = exp; DOT; DEFAULT; LPAR; RPAR; m = msg_info { Syntax.SendExp { Syntax.send_head_contract = contr; send_head_method = None ; send_args = []; send_msg_info = m }, () } | contr = exp; DOT; mtd = IDENT; lst = exp_list; m = msg_info { Syntax.SendExp { Syntax.send_head_contract = contr; send_head_method = Some mtd ; send_args = (lst); send_msg_info = m }, () } | ADDRESS; LPAR; e = exp; RPAR { Syntax.AddressExp e, () } | NOT; e = exp { Syntax.NotExp e, () } | THIS { Syntax.ThisExp, () } | l = lexp; { Syntax.ArrayAccessExp l, () } ; %inline exp_list: lst = plist(exp) {lst} msg_info: | v = value_info; r = reentrance_info { { Syntax.message_value_info = v; message_reentrance_info = r } } ; value_info: | (* empty *) { None } | ALONG; v = exp; { Some v } ; reentrance_info: | REENTRANCE; b = block { b } ; lexp: | s = exp; LSQBR; idx = exp; RSQBR { Syntax.ArrayAccessLExp { Syntax.array_access_array = s; array_access_index = idx} } ; ================================================ FILE: src/parse/parser_test.ml ================================================ open Lexer open Lexing open Printf (* The following two functions comes from * https://github.com/realworldocaml/examples/tree/master/code/parsing-test * which is under UNLICENSE *) let print_position outx lexbuf = let pos = lexbuf.lex_curr_p in fprintf outx "%s:%d:%d" pos.pos_fname pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) let parse_with_error lexbuf = try Parser.file Lexer.read lexbuf with | SyntaxError msg -> fprintf stderr "%a: %s\n" print_position lexbuf msg; exit (-1) | Parser.Error -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) | _ -> fprintf stderr "%a: syntax error\n" print_position lexbuf; exit (-1) let _ = let lexbuf = Lexing.from_channel stdin in let _ = parse_with_error lexbuf in Printf.printf "Finished parsing.\n" ================================================ FILE: src/run_tests.sh ================================================ npm run build lib_path="../lib/bs/native/" $lib_path"codegen_test.native" || exit 1 $lib_path"lib_test.native" || exit 1 $lib_path"hex_test.native" || exit 1 for f in `ls parse/examples/*.bbo ../sketch/*.bbo` do echo "trying" $f cat $f | $lib_path"parser_test.native" || \ exit 1 cat $f | $lib_path"ast_test.native" || \ exit 1 cat $f | $lib_path"codegen_test2.native" || \ exit 1 cat $f | $lib_path"bamboo.native" --abi | jq || \ exit 1 done for f in `ls parse/negative_examples/*.bbo` do echo "trying" $f if cat $f | $lib_path"codegen_test2.native" then exit 1 fi done echo "what should succeed has succeeded; what should fail has failed."