merge dev conflict
This commit is contained in:
galfour
commit
25b07af6ae
1
.gitignore
vendored
1
.gitignore
vendored
@ -3,3 +3,4 @@
|
||||
*~
|
||||
cache/*
|
||||
Version.ml
|
||||
/_opam/
|
||||
|
||||
@ -9,34 +9,21 @@ stages:
|
||||
- test
|
||||
|
||||
.website_build: &website_build
|
||||
stage: build_and_deploy_website
|
||||
stage: test # TODO DODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODO restore to build_and_deploy_website
|
||||
image: node:8
|
||||
before_script:
|
||||
- scripts/install_native_dependencies.sh
|
||||
# TODO: these things are moved to scripts in other branches.
|
||||
- wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux
|
||||
- cp opam-2.0.1-x86_64-linux /usr/local/bin/opam
|
||||
- chmod +x /usr/local/bin/opam
|
||||
- scripts/install_opam.sh # TODO: or scripts/install_build_environment.sh ?
|
||||
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
|
||||
|
||||
# Initialise opam
|
||||
- printf '' | opam init --bare
|
||||
- eval $(opam config env)
|
||||
|
||||
# Create switch
|
||||
- printf '' | opam switch create toto ocaml-base-compiler.4.06.1
|
||||
- scripts/setup_switch.sh
|
||||
- eval $(opam config env)
|
||||
|
||||
# Show versions and current switch
|
||||
- echo "$PATH"
|
||||
- opam --version
|
||||
- printf '' | ocaml
|
||||
- opam switch
|
||||
- scripts/debug_show_versions.sh || true
|
||||
|
||||
# install deps for internal documentation
|
||||
- opam install -y odoc
|
||||
- vendors/opam-repository-tools/rewrite-local-opam-repository.sh
|
||||
- opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/"
|
||||
# - vendors/opam-repository-tools/rewrite-local-opam-repository.sh
|
||||
# - opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/"
|
||||
- opam install -y --build-test --deps-only ./src/
|
||||
- dune build -p ligo
|
||||
# TODO: also try instead from time to time:
|
||||
@ -75,44 +62,36 @@ stages:
|
||||
before_script:
|
||||
# Install dependencies
|
||||
# rsync is needed by opam to sync a package installed from a local directory with the copy in ~/.opam
|
||||
- apt-get update -qq
|
||||
- scripts/install_native_dependencies.sh
|
||||
- scripts/install_opam.sh
|
||||
- scripts/install_opam.sh # TODO: or scripts/install_build_environment.sh ?
|
||||
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
|
||||
|
||||
# Initialise opam, create switch, load opam environment variables
|
||||
- printf '' | opam init --bare
|
||||
- printf '' | opam switch create ligo-switch ocaml-base-compiler.4.06.1
|
||||
- echo "$PATH"; which ocaml || true
|
||||
- eval $(opam config env)
|
||||
|
||||
# Show versions and current switch
|
||||
- echo "$PATH"
|
||||
- opam --version
|
||||
- printf '' | ocaml
|
||||
- opam switch
|
||||
- echo "$PATH"; which ocaml || true
|
||||
- scripts/setup_switch.sh
|
||||
- echo "$PATH"; which ocaml || true
|
||||
- eval $(opam config env)
|
||||
- echo "$PATH"; which ocaml || true
|
||||
- scripts/debug_show_versions.sh || true
|
||||
|
||||
local-dune-job:
|
||||
<<: *before_script
|
||||
stage: test
|
||||
script:
|
||||
- scripts/setup_ligo_opam_repository.sh
|
||||
- opam install -y --build-test --deps-only ./src/
|
||||
- dune build -p ligo
|
||||
# TODO: also try instead from time to time:
|
||||
#- (cd ./src/; dune build -p ligo)
|
||||
- scripts/install_vendors_deps.sh
|
||||
- scripts/build_ligo_local.sh
|
||||
- dune build @ligo-test
|
||||
# artifacts:
|
||||
# paths:
|
||||
# - src/ligo/bin/cli.ml
|
||||
|
||||
local-repo-job:
|
||||
<<: *before_script
|
||||
stage: test
|
||||
script:
|
||||
- vendors/opam-repository-tools/rewrite-local-opam-repository.sh
|
||||
- opam repository add localrepo "file://$PWD/vendors/ligo-opam-repository-local-generated/"
|
||||
#--build-test
|
||||
- opam install -y ligo
|
||||
# TODO: uncomment this
|
||||
|
||||
# TODO
|
||||
# local-repo-job:
|
||||
# <<: *before_script
|
||||
# stage: test
|
||||
# script:
|
||||
# - scripts/install_vendors_deps.sh
|
||||
# # TODO: also try from time to time with --build-test
|
||||
# - opam install -y ligo
|
||||
|
||||
remote-repo-job:
|
||||
<<: *before_script
|
||||
@ -130,19 +109,21 @@ remote-repo-job:
|
||||
only:
|
||||
- master
|
||||
|
||||
# Run a docker build without publishing to the registry
|
||||
build-current-docker-image:
|
||||
stage: build_docker
|
||||
<<: *docker
|
||||
<<: *docker_build
|
||||
except:
|
||||
- master
|
||||
- dev
|
||||
# TODO: uncomment this
|
||||
|
||||
# # Run a docker build without publishing to the registry
|
||||
# build-current-docker-image:
|
||||
# stage: test # TODO DODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODO restore to build_docker
|
||||
# <<: *docker
|
||||
# <<: *docker_build
|
||||
# except:
|
||||
# - master
|
||||
# - dev
|
||||
|
||||
# When a MR/PR is merged to dev
|
||||
# take the previous build and publish it to Docker Hub
|
||||
build-and-publish-latest-docker-image:
|
||||
stage: build_and_deploy_docker
|
||||
stage: test # TODO DODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODODO restore to build_and_deploy_docker
|
||||
<<: *docker
|
||||
<<: *docker_build
|
||||
after_script:
|
||||
|
||||
38
Makefile
38
Makefile
@ -1,3 +1,37 @@
|
||||
.ONESHELL:
|
||||
|
||||
all: test
|
||||
|
||||
# Use install-deps instead of 'install' because usually 'make install' adds a
|
||||
# binary to the system path and we don't want to confuse users
|
||||
install-deps:
|
||||
# Install ligo/tezos specific system-level dependencies
|
||||
sudo scripts/install_native_dependencies.sh
|
||||
scripts/install_build_environment.sh # TODO: or scripts/install_opam.sh ?
|
||||
|
||||
build-deps:
|
||||
scripts/install_native_dependencies.sh
|
||||
scripts/install_opam.sh
|
||||
echo aa
|
||||
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
|
||||
# Create opam dev switch locally for use with Ligo, add merlin/etc
|
||||
if [ -n "`opam switch show | grep -P ".+/ligo"`" ];
|
||||
then :; else scripts/setup_dev_switch.sh;
|
||||
fi
|
||||
echo bb
|
||||
eval $$(opam config env)
|
||||
echo cc
|
||||
# Install OCaml build dependencies for Ligo
|
||||
scripts/install_vendors_deps.sh
|
||||
echo dd
|
||||
scripts/install_ligo_with_dependencies.sh # TODO: rename & cleanup
|
||||
echo ee
|
||||
|
||||
build: build-deps
|
||||
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
|
||||
eval $$(opam config env)
|
||||
# Build Ligo for local dev use
|
||||
scripts/build_ligo_local.sh
|
||||
|
||||
test: build
|
||||
export PATH="/usr/local/bin$${PATH:+:}$${PATH:-}"
|
||||
eval $$(opam config env)
|
||||
scripts/test_ligo.sh
|
||||
|
||||
@ -19,12 +19,17 @@ WORKDIR /ligo
|
||||
# Install required native dependencies
|
||||
RUN sh scripts/install_native_dependencies.sh
|
||||
|
||||
# Setup a custom opam repository where ligo is published
|
||||
RUN sh scripts/setup_ligo_opam_repository.sh
|
||||
# Install OPAM
|
||||
# TODO: or scripts/install_build_environment.sh ?
|
||||
RUN sh scripts/install_opam.sh
|
||||
|
||||
# Creat opam switch
|
||||
RUN sh scripts/setup_switch.sh
|
||||
|
||||
RUN opam update
|
||||
|
||||
# Install ligo
|
||||
RUN sh scripts/install_vendors_deps.sh
|
||||
RUN sh scripts/install_ligo_with_dependencies.sh
|
||||
|
||||
# Use the ligo binary as a default command
|
||||
|
||||
@ -0,0 +1 @@
|
||||
udfg-WYEzK3rTbfS71zFI7HOr3AvRoa9KMuzObp9wTs.4Dc00ftieGaWDmacztwSS7euFOKPULDHjUNzikwPvao
|
||||
BIN
index.tar.gz
BIN
index.tar.gz
Binary file not shown.
25
makefile
25
makefile
@ -1,25 +0,0 @@
|
||||
# Use install-deps instead of 'install' because usually 'make install' adds a
|
||||
# binary to the system path and we don't want to confuse users
|
||||
install-deps:
|
||||
# Install ligo/tezos specific system-level dependencies
|
||||
sudo scripts/install_native_dependencies.sh
|
||||
|
||||
build-deps:
|
||||
# Create opam dev switch locally for use with Ligo, add merlin/etc
|
||||
if [ -n "`opam switch show | grep -P ".+/ligo"`" ];
|
||||
then exit; else scripts/setup_dev_switch.sh;
|
||||
fi
|
||||
# Set up the local ligo opam repository so that it can be built
|
||||
if [ -n "`opam repo list --safe | grep -P "ligo-opam-repository"`" ];
|
||||
then exit; else scripts/setup_ligo_opam_repository.sh;
|
||||
fi
|
||||
# Install OCaml build dependencies for Ligo
|
||||
scripts/install_ligo_with_dependencies.sh
|
||||
|
||||
build: build-deps
|
||||
# Build Ligo for local dev use
|
||||
scripts/build_ligo_local.sh
|
||||
|
||||
.ONESHELL:
|
||||
test: build
|
||||
scripts/test_ligo.sh
|
||||
@ -18,6 +18,7 @@ depends: [
|
||||
"proto-alpha-utils"
|
||||
"yojson"
|
||||
"alcotest" { with-test }
|
||||
"getopt"
|
||||
]
|
||||
build: [
|
||||
[ "dune" "build" "-p" name "-j" jobs ]
|
||||
|
||||
2
repo
2
repo
@ -1,3 +1,3 @@
|
||||
opam-version: "2.0"
|
||||
archive-mirrors: "cache"
|
||||
stamp: "a989886f"
|
||||
stamp: "b4649b8f"
|
||||
|
||||
@ -1,2 +1,8 @@
|
||||
eval $(opam env)
|
||||
dune build -p ligo
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
eval $(opam config env)
|
||||
dune build src # TODO: make it work with -p ligo
|
||||
|
||||
# TODO: also try instead from time to time:
|
||||
#- (cd ./src/; dune build -p ligo)
|
||||
|
||||
8
scripts/debug_show_versions.sh
Executable file
8
scripts/debug_show_versions.sh
Executable file
@ -0,0 +1,8 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
echo "$PATH"
|
||||
opam --version
|
||||
printf '' | ocaml
|
||||
opam switch
|
||||
|
||||
@ -1,3 +1,6 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
# This script installs opam for the user. It should NOT be included in any makefiles/etc.
|
||||
|
||||
if [ -n "`which opam`" ]
|
||||
|
||||
@ -1,10 +1,27 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
# TODO: this has many different modes of failure (file temp.opam-2.0.1-x86_64-linux.download-in-progress already exists, /usr/local/bin/opam already exists and is a directory or hard link, …)
|
||||
# Try to improve these aspects.
|
||||
|
||||
if command -v wget >/dev/null 2>&1; then
|
||||
wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O temp.opam-2.0.1-x86_64-linux.download-in-progress
|
||||
else
|
||||
curl -L https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux --output temp.opam-2.0.1-x86_64-linux.download-in-progress
|
||||
fi
|
||||
|
||||
# debug
|
||||
ls
|
||||
apt -y install hexdump || true
|
||||
apt -y install xxd || true
|
||||
(cat temp.opam-2.0.1-x86_64-linux.download-in-progress | xxd | head -n 30) || true
|
||||
|
||||
cp -i temp.opam-2.0.1-x86_64-linux.download-in-progress /usr/local/bin/opam
|
||||
chmod +x /usr/local/bin/opam
|
||||
rm temp.opam-2.0.1-x86_64-linux.download-in-progress
|
||||
|
||||
which opam || true
|
||||
|
||||
|
||||
opam init -a --bare
|
||||
|
||||
12
scripts/install_vendors_deps.sh
Executable file
12
scripts/install_vendors_deps.sh
Executable file
@ -0,0 +1,12 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
# Install local dependencies
|
||||
opam install -y ./vendors/ligo-utils/simple-utils
|
||||
opam install -y ./vendors/ligo-utils/tezos-protocol-alpha
|
||||
opam install -y ./vendors/ligo-utils/tezos-protocol-alpha-parameters
|
||||
opam install -y ./vendors/ligo-utils/memory-proto-alpha
|
||||
opam install -y ./vendors/ligo-utils/tezos-utils/michelson-parser
|
||||
opam install -y ./vendors/ligo-utils/tezos-utils
|
||||
opam install -y ./vendors/ligo-utils/proto-alpha-utils
|
||||
opam install -y getopt ppx_deriving menhir
|
||||
@ -1,4 +1,7 @@
|
||||
opam switch create . ocaml-base-compiler.4.06.1
|
||||
eval $(opam env)
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
"$(dirname "$0")"/setup_switch.sh
|
||||
|
||||
opam install -y ocp-indent tuareg merlin alcotest-lwt crowbar
|
||||
opam -y user-setup install
|
||||
|
||||
15
scripts/setup_switch.sh
Executable file
15
scripts/setup_switch.sh
Executable file
@ -0,0 +1,15 @@
|
||||
#!/bin/sh
|
||||
set -e
|
||||
set -x
|
||||
|
||||
printf '' | opam switch create . 4.07.1 # toto ocaml-base-compiler.4.06.1
|
||||
eval $(opam config env)
|
||||
|
||||
# Add Tezos opam repository
|
||||
opam repo add tezos-opam-repository https://gitlab.com/nomadic-labs/tezos-opam-repository.git
|
||||
|
||||
# TODO: move this to install_vendor_deps.sh
|
||||
# Pin the versions of some dependencies
|
||||
opam pin -y zarith 1.7
|
||||
opam pin -y ipaddr 3.1.0
|
||||
opam pin -y macaddr 3.1.0
|
||||
@ -1,2 +1,5 @@
|
||||
eval $(opam env)
|
||||
#!/bin/sh
|
||||
set -e
|
||||
|
||||
eval $(opam config env)
|
||||
dune build @ligo-test
|
||||
|
||||
@ -1,20 +0,0 @@
|
||||
switch=titi
|
||||
cd src/ligo
|
||||
sudo apt -y install libev-dev libhidapi-dev
|
||||
opam init
|
||||
eval $(opam env)
|
||||
opam switch create $switch ocaml-base-compiler.4.06.1
|
||||
eval $(opam env --switch=$switch --set-switch)
|
||||
opam repository add new-tezos https://gitlab.com/ligolang/new-tezos-opam-repository.git
|
||||
|
||||
# si une build a déjà été tentée, il vaut mieux git add tout ce qui est utile et git clean -dfx pour supprimer tout le reste (dune 1.7 crée des fichiers non compatibles avec dune 1.6)
|
||||
opam install -y ocplib-endian alcotest
|
||||
|
||||
(cd ligo-parser && opam install -y .)
|
||||
eval $(opam env)
|
||||
(cd ligo-helpers && opam install -y .)
|
||||
eval $(opam env)
|
||||
(opam install -y .)
|
||||
eval $(opam env)
|
||||
opam install merlin ocp-indent ledit
|
||||
opam user-setup install
|
||||
@ -6,7 +6,7 @@
|
||||
tezos-utils
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -92,7 +92,7 @@ and literal =
|
||||
| Literal_bytes of bytes
|
||||
| Literal_address of string
|
||||
| Literal_timestamp of int
|
||||
| Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
|
||||
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||
|
||||
and 'a matching =
|
||||
| Match_bool of {
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
ast_simplified ; Is that a good idea?
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -open Simple_utils))
|
||||
)
|
||||
|
||||
@ -122,7 +122,7 @@ and literal =
|
||||
| Literal_string of string
|
||||
| Literal_bytes of bytes
|
||||
| Literal_address of string
|
||||
| Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
|
||||
| Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||
|
||||
and access =
|
||||
| Access_tuple of int
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
)
|
||||
(package ligo)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -open Simple_utils))
|
||||
)
|
||||
|
||||
@ -3,8 +3,6 @@ open Mini_c
|
||||
open Environment
|
||||
open Michelson
|
||||
|
||||
module Stack = Meta_michelson.Stack
|
||||
|
||||
let get : environment -> string -> michelson result = fun e s ->
|
||||
let%bind (_ , position) =
|
||||
let error =
|
||||
|
||||
@ -2,10 +2,8 @@ open Trace
|
||||
open Mini_c
|
||||
|
||||
open Michelson
|
||||
module Stack = Meta_michelson.Stack
|
||||
module Contract_types = Meta_michelson.Types
|
||||
|
||||
open Memory_proto_alpha.Script_ir_translator
|
||||
open Memory_proto_alpha.Protocol.Script_ir_translator
|
||||
|
||||
open Operators.Compiler
|
||||
|
||||
|
||||
@ -2,18 +2,52 @@ open Trace
|
||||
open Mini_c.Types
|
||||
|
||||
open Proto_alpha_utils.Memory_proto_alpha
|
||||
open Protocol
|
||||
open Script_ir_translator
|
||||
|
||||
module O = Tezos_utils.Michelson
|
||||
module Contract_types = Meta_michelson.Types
|
||||
|
||||
module Ty = struct
|
||||
|
||||
open Script_typed_ir
|
||||
|
||||
let nat_k = Nat_key None
|
||||
let tez_k = Mutez_key None
|
||||
let int_k = Int_key None
|
||||
let string_k = String_key None
|
||||
let address_k = Address_key None
|
||||
let timestamp_k = Timestamp_key None
|
||||
let bytes_k = Bytes_key None
|
||||
(* let timestamp_k = Timestamp_key None *)
|
||||
|
||||
let unit = Unit_t None
|
||||
let bytes = Bytes_t None
|
||||
let nat = Nat_t None
|
||||
let tez = Mutez_t None
|
||||
let int = Int_t None
|
||||
let big_map k v = Big_map_t (k, v, None)
|
||||
let signature = Signature_t None
|
||||
let operation = Operation_t None
|
||||
let bool = Bool_t None
|
||||
let mutez = Mutez_t None
|
||||
let string = String_t None
|
||||
let key = Key_t None
|
||||
let list a = List_t (a, None)
|
||||
let set a = Set_t (a, None)
|
||||
let address = Address_t None
|
||||
let option a = Option_t ((a, None), None, None)
|
||||
let contract a = Contract_t (a, None)
|
||||
let lambda a b = Lambda_t (a, b, None)
|
||||
let timestamp = Timestamp_t None
|
||||
let map a b = Map_t (a, b, None)
|
||||
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
|
||||
let union a b = Union_t ((a, None), (b, None), None)
|
||||
|
||||
|
||||
let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
|
||||
let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
|
||||
|
||||
let comparable_type_base : type_base -> ex_comparable_ty result = fun tb ->
|
||||
let open Contract_types in
|
||||
let return x = ok @@ Ex_comparable_ty x in
|
||||
match tb with
|
||||
| Base_unit -> fail (not_comparable "unit")
|
||||
@ -42,7 +76,6 @@ module Ty = struct
|
||||
| T_contract _ -> fail (not_comparable "contract")
|
||||
|
||||
let base_type : type_base -> ex_ty result = fun b ->
|
||||
let open Contract_types in
|
||||
let return x = ok @@ Ex_ty x in
|
||||
match b with
|
||||
| Base_unit -> return unit
|
||||
@ -63,61 +96,60 @@ module Ty = struct
|
||||
| T_pair (t, t') -> (
|
||||
type_ t >>? fun (Ex_ty t) ->
|
||||
type_ t' >>? fun (Ex_ty t') ->
|
||||
ok @@ Ex_ty (Contract_types.pair t t')
|
||||
ok @@ Ex_ty (pair t t')
|
||||
)
|
||||
| T_or (t, t') -> (
|
||||
type_ t >>? fun (Ex_ty t) ->
|
||||
type_ t' >>? fun (Ex_ty t') ->
|
||||
ok @@ Ex_ty (Contract_types.union t t')
|
||||
ok @@ Ex_ty (union t t')
|
||||
)
|
||||
| T_function (arg, ret) ->
|
||||
let%bind (Ex_ty arg) = type_ arg in
|
||||
let%bind (Ex_ty ret) = type_ ret in
|
||||
ok @@ Ex_ty (Contract_types.lambda arg ret)
|
||||
ok @@ Ex_ty (lambda arg ret)
|
||||
| T_deep_closure (c, arg, ret) ->
|
||||
let%bind (Ex_ty capture) = environment_representation c in
|
||||
let%bind (Ex_ty arg) = type_ arg in
|
||||
let%bind (Ex_ty ret) = type_ ret in
|
||||
ok @@ Ex_ty Contract_types.(pair (lambda (pair arg capture) ret) capture)
|
||||
ok @@ Ex_ty (pair (lambda (pair arg capture) ret) capture)
|
||||
| T_map (k, v) ->
|
||||
let%bind (Ex_comparable_ty k') = comparable_type k in
|
||||
let%bind (Ex_ty v') = type_ v in
|
||||
ok @@ Ex_ty Contract_types.(map k' v')
|
||||
ok @@ Ex_ty (map k' v')
|
||||
| T_list t ->
|
||||
let%bind (Ex_ty t') = type_ t in
|
||||
ok @@ Ex_ty Contract_types.(list t')
|
||||
ok @@ Ex_ty (list t')
|
||||
| T_set t -> (
|
||||
let%bind (Ex_comparable_ty t') = comparable_type t in
|
||||
ok @@ Ex_ty Contract_types.(set t')
|
||||
ok @@ Ex_ty (set t')
|
||||
)
|
||||
| T_option t ->
|
||||
let%bind (Ex_ty t') = type_ t in
|
||||
ok @@ Ex_ty Contract_types.(option t')
|
||||
ok @@ Ex_ty (option t')
|
||||
| T_contract t ->
|
||||
let%bind (Ex_ty t') = type_ t in
|
||||
ok @@ Ex_ty Contract_types.(contract t')
|
||||
ok @@ Ex_ty (contract t')
|
||||
|
||||
and environment_representation = fun e ->
|
||||
match List.rev_uncons_opt e with
|
||||
| None -> ok @@ Ex_ty Contract_types.unit
|
||||
| None -> ok @@ Ex_ty unit
|
||||
| Some (hds , tl) -> (
|
||||
let%bind tl_ty = type_ @@ snd tl in
|
||||
let aux (Ex_ty prec_ty) cur =
|
||||
let%bind (Ex_ty cur_ty) = type_ @@ snd cur in
|
||||
ok @@ Ex_ty Contract_types.(pair prec_ty cur_ty)
|
||||
ok @@ Ex_ty (pair prec_ty cur_ty)
|
||||
in
|
||||
bind_fold_right_list aux tl_ty hds
|
||||
)
|
||||
|
||||
and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env ->
|
||||
let open Meta_michelson in
|
||||
and environment : environment -> ex_stack_ty result = fun env ->
|
||||
let%bind lst =
|
||||
bind_map_list type_
|
||||
@@ List.map snd env in
|
||||
let aux (Stack.Ex_stack_ty st) (Ex_ty cur) =
|
||||
Stack.Ex_stack_ty (Stack.stack cur st)
|
||||
let aux (Ex_stack_ty st) (Ex_ty cur) =
|
||||
Ex_stack_ty (Item_t(cur, st, None))
|
||||
in
|
||||
ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst
|
||||
ok @@ List.fold_right' aux (Ex_stack_ty Empty_t) lst
|
||||
|
||||
end
|
||||
|
||||
|
||||
@ -3,13 +3,13 @@
|
||||
(public_name ligo.compiler)
|
||||
(libraries
|
||||
simple-utils
|
||||
proto-alpha-utils
|
||||
tezos-utils
|
||||
meta_michelson
|
||||
mini_c
|
||||
operators
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
|
||||
)
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
open Mini_c.Types
|
||||
open Memory_proto_alpha
|
||||
open Proto_alpha_utils.Memory_proto_alpha
|
||||
open X
|
||||
open Proto_alpha_utils.Trace
|
||||
open Protocol
|
||||
open Script_typed_ir
|
||||
open Script_ir_translator
|
||||
|
||||
|
||||
3
src/dune
3
src/dune
@ -6,11 +6,10 @@
|
||||
simple-utils
|
||||
tezos-utils
|
||||
tezos-micheline
|
||||
meta_michelson
|
||||
main
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@ -17,6 +17,7 @@ depends: [
|
||||
"proto-alpha-utils"
|
||||
"yojson"
|
||||
"alcotest" { with-test }
|
||||
"getopt"
|
||||
]
|
||||
build: [
|
||||
[ "dune" "build" "-p" name "-j" jobs ]
|
||||
|
||||
@ -15,7 +15,7 @@
|
||||
compiler
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils ))
|
||||
)
|
||||
|
||||
@ -2,7 +2,8 @@ open Proto_alpha_utils
|
||||
open Trace
|
||||
open Mini_c
|
||||
open! Compiler.Program
|
||||
open Memory_proto_alpha.Script_ir_translator
|
||||
open Memory_proto_alpha.Protocol.Script_ir_translator
|
||||
open Memory_proto_alpha.X
|
||||
|
||||
let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_typed_value result =
|
||||
let Compiler.Program.{input;output;body} : compiled_program = program in
|
||||
@ -15,8 +16,8 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) :
|
||||
let%bind descr =
|
||||
Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
|
||||
Memory_proto_alpha.parse_michelson body
|
||||
(Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in
|
||||
let open! Memory_proto_alpha.Script_interpreter in
|
||||
(Item_t (input_ty, Empty_t, None)) (Item_t (output_ty, Empty_t, None)) in
|
||||
let open! Memory_proto_alpha.Protocol.Script_interpreter in
|
||||
let%bind (Item(output, Empty)) =
|
||||
Trace.trace_tzresult_lwt (simple_error "error of execution") @@
|
||||
Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
|
||||
|
||||
@ -259,7 +259,7 @@ let run_contract ?amount source_filename entry_point storage input syntax =
|
||||
parsify_expression syntax input in
|
||||
let options =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in
|
||||
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
|
||||
(make_options ?amount ()) in
|
||||
Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl)
|
||||
|
||||
@ -271,7 +271,7 @@ let run_function ?amount source_filename entry_point parameter syntax =
|
||||
parsify_expression syntax parameter in
|
||||
let options =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in
|
||||
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
|
||||
(make_options ?amount ()) in
|
||||
Run_simplified.run_simplityped ~options typed entry_point parameter'
|
||||
|
||||
@ -281,6 +281,6 @@ let evaluate_value ?amount source_filename entry_point syntax =
|
||||
type_file syntax source_filename in
|
||||
let options =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let amount = Option.bind (fun amount -> Alpha_context.Tez.of_string amount) amount in
|
||||
let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in
|
||||
(make_options ?amount ()) in
|
||||
Run_simplified.evaluate_simplityped ~options typed entry_point
|
||||
|
||||
@ -1,30 +0,0 @@
|
||||
open Proto_alpha_utils.Error_monad
|
||||
|
||||
let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment ()
|
||||
|
||||
let tc = dummy_environment.tezos_context
|
||||
|
||||
module Proto_alpha = Proto_alpha_utils.Memory_proto_alpha
|
||||
open Proto_alpha
|
||||
open Alpha_context
|
||||
open Alpha_environment
|
||||
|
||||
let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v
|
||||
let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes ->
|
||||
force_lwt ~msg:"unpacking : parse" (
|
||||
if Compare.Int.(MBytes.length bytes >= 1) &&
|
||||
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
|
||||
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
|
||||
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
|
||||
| None -> return None
|
||||
| Some expr ->
|
||||
Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x))
|
||||
else
|
||||
return None
|
||||
)
|
||||
|
||||
let unpack ty a = match unpack_opt ty a with
|
||||
| None -> raise @@ Failure "unpacking : of_bytes"
|
||||
| Some x -> x
|
||||
|
||||
let blake2b b = Alpha_environment.Raw_hashes.blake2b b
|
||||
@ -1,317 +0,0 @@
|
||||
open Misc
|
||||
|
||||
open Proto_alpha_utils.Error_monad
|
||||
open Memory_proto_alpha
|
||||
open Alpha_context
|
||||
|
||||
open Script_ir_translator
|
||||
open Script_typed_ir
|
||||
|
||||
module Option = Simple_utils.Option
|
||||
module Cast = Proto_alpha_utils.Cast
|
||||
|
||||
type ('param, 'storage) toplevel = {
|
||||
param_type : 'param ty ;
|
||||
storage_type : 'storage ty ;
|
||||
code : ('param * 'storage, packed_internal_operation list * 'storage) lambda
|
||||
}
|
||||
|
||||
type ex_toplevel =
|
||||
Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel
|
||||
|
||||
let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type =
|
||||
let toplevel_str = Streams.read_file toplevel_path in
|
||||
contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } ->
|
||||
let toplevel_expr = Cast.tl_of_string toplevel_str in
|
||||
let (param_ty_node, storage_ty_node, code_field) =
|
||||
force_ok_alpha ~msg:"parsing toplevel" @@
|
||||
parse_toplevel toplevel_expr in
|
||||
let (Ex_ty param_type, _) =
|
||||
force_ok_alpha ~msg:"parse arg ty" @@
|
||||
Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in
|
||||
let (Ex_ty storage_type, _) =
|
||||
force_ok_alpha ~msg:"parse storage ty" @@
|
||||
parse_storage_ty context storage_ty_node in
|
||||
let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in
|
||||
let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in
|
||||
let param_type_full = Pair_t ((claimed_parameter_type, None, None),
|
||||
(claimed_storage_type, None, None), None) in
|
||||
let ret_type_full =
|
||||
Pair_t ((List_t (Operation_t None, None), None, None),
|
||||
(claimed_storage_type, None, None), None) in
|
||||
parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type })
|
||||
context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) ->
|
||||
Error_monad.return {
|
||||
param_type = claimed_parameter_type;
|
||||
storage_type = claimed_storage_type;
|
||||
code ;
|
||||
}
|
||||
|
||||
let make_toplevel code storage_type param_type =
|
||||
{ param_type ; storage_type ; code }
|
||||
|
||||
module type ENVIRONMENT = sig
|
||||
val identities : identity list
|
||||
val tezos_context : t
|
||||
end
|
||||
|
||||
type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack
|
||||
|
||||
open Error_monad
|
||||
|
||||
module Step (Env: ENVIRONMENT) = struct
|
||||
open Env
|
||||
|
||||
type config = {
|
||||
source : Contract.t option ;
|
||||
payer : Contract.t option ;
|
||||
self : Contract.t option ;
|
||||
visitor : (Script_interpreter.ex_descr_stack -> unit) option ;
|
||||
timestamp : Script_timestamp.t option ;
|
||||
debug_visitor : (ex_typed_stack -> unit) option ;
|
||||
amount : Tez.t option ;
|
||||
}
|
||||
|
||||
let no_config = {
|
||||
source = None ;
|
||||
payer = None ;
|
||||
self = None ;
|
||||
visitor = None ;
|
||||
debug_visitor = None ;
|
||||
timestamp = None ;
|
||||
amount = None ;
|
||||
}
|
||||
|
||||
let of_param base param = match param with
|
||||
| None -> base
|
||||
| Some _ as x -> x
|
||||
|
||||
let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () =
|
||||
let base_config = Option.unopt ~default:no_config base_config in {
|
||||
source = Option.bind_eager_or source base_config.source ;
|
||||
payer = Option.bind_eager_or payer base_config.payer ;
|
||||
self = Option.bind_eager_or self base_config.self ;
|
||||
visitor = Option.bind_eager_or visitor base_config.visitor ;
|
||||
debug_visitor = Option.bind_eager_or debug_visitor base_config.debug_visitor ;
|
||||
timestamp = Option.bind_eager_or timestamp base_config.timestamp ;
|
||||
amount = Option.bind_eager_or amount base_config.amount ;
|
||||
}
|
||||
|
||||
open Error_monad
|
||||
|
||||
let debug_visitor ?f () =
|
||||
let open Script_interpreter in
|
||||
let aux (Ex_descr_stack (descr, stack)) =
|
||||
(match (descr.instr, descr.bef) with
|
||||
| Nop, Item_t (String_t _, stack_ty, _) -> (
|
||||
let (Item (s, stack)) = stack in
|
||||
if s = "_debug"
|
||||
then (
|
||||
match f with
|
||||
| None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack
|
||||
| Some f -> f (Ex_typed_stack(stack_ty, stack))
|
||||
) else ()
|
||||
)
|
||||
| _ -> ()) ;
|
||||
() in
|
||||
aux
|
||||
|
||||
let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) =
|
||||
let source = Option.unopt
|
||||
~default:(List.nth identities 0).implicit_contract config.source in
|
||||
let payer = Option.unopt
|
||||
~default:(List.nth identities 1).implicit_contract config.payer in
|
||||
let self = Option.unopt
|
||||
~default:(List.nth identities 2).implicit_contract config.self in
|
||||
let amount = Option.unopt ~default:(Tez.one) config.amount in
|
||||
let visitor =
|
||||
let default = debug_visitor ?f:config.debug_visitor () in
|
||||
Option.unopt ~default config.visitor in
|
||||
let tezos_context = match config.timestamp with
|
||||
| None -> tezos_context
|
||||
| Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in
|
||||
Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) ->
|
||||
return stack
|
||||
|
||||
let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) =
|
||||
let open Script_interpreter in
|
||||
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) ->
|
||||
return (b, c)
|
||||
|
||||
let step_3_1 ?config (a:'a) (b:'b) (c:'c)
|
||||
(descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) =
|
||||
let open Script_interpreter in
|
||||
step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) ->
|
||||
return d
|
||||
|
||||
let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) =
|
||||
let open Script_interpreter in
|
||||
step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) ->
|
||||
return c
|
||||
|
||||
let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) =
|
||||
let open Script_interpreter in
|
||||
step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) ->
|
||||
return b
|
||||
|
||||
let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) =
|
||||
step_1_1 ?config a descr
|
||||
|
||||
let step ?config stack code =
|
||||
force_lwt ~msg:"running a step" @@ step_lwt ?config stack code
|
||||
|
||||
end
|
||||
|
||||
let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} =
|
||||
let { code ; _ } : (_, _) toplevel = toplevel in
|
||||
|
||||
let source = Option.unopt
|
||||
~default:(List.nth identities 0).implicit_contract source in
|
||||
let payer = Option.unopt
|
||||
~default:(List.nth identities 1).implicit_contract payer in
|
||||
let self = Option.unopt
|
||||
~default:(List.nth identities 2).implicit_contract self in
|
||||
let amount = Tez.one in
|
||||
|
||||
Script_interpreter.interp context ~source ~payer ~self amount code (param, storage)
|
||||
>>=?? fun ((ops, storage), new_ctxt) ->
|
||||
let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in
|
||||
return (storage, ops, gas)
|
||||
|
||||
let run_lwt ?source ?payer ?self toplevel storage param env =
|
||||
run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) ->
|
||||
return storage
|
||||
|
||||
let run ?environment toplevel storage param =
|
||||
contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param
|
||||
|
||||
let run_node ?environment toplevel storage_node param_node =
|
||||
contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} ->
|
||||
let {param_type ; storage_type ; _ } = toplevel in
|
||||
parse_data context param_type param_node >>=?? fun (param, _) ->
|
||||
parse_data context storage_type storage_node >>=?? fun (storage, _) ->
|
||||
let storage = run toplevel storage param in
|
||||
unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) ->
|
||||
return storage_node
|
||||
|
||||
let run_str toplevel storage_str param_str =
|
||||
let param_node = Cast.node_of_string param_str in
|
||||
let storage_node = Cast.node_of_string storage_str in
|
||||
run_node toplevel storage_node param_node
|
||||
|
||||
type input = {
|
||||
toplevel_path : string ;
|
||||
storage : string ;
|
||||
parameter : string
|
||||
}
|
||||
|
||||
let parse_json json_str : input =
|
||||
let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in
|
||||
let json = match json with
|
||||
| `O json -> json
|
||||
| _ -> raise @@ Failure "main_contract: not recorD"
|
||||
in
|
||||
let open Json in
|
||||
let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in
|
||||
let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in
|
||||
let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in
|
||||
{ toplevel_path ; storage ; parameter }
|
||||
|
||||
let generate_json (storage_node:Script.node) : string =
|
||||
let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in
|
||||
let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in
|
||||
Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ;
|
||||
Format.flush_str_formatter ()
|
||||
|
||||
module Types = struct
|
||||
open Script_typed_ir
|
||||
|
||||
let union a b = Union_t ((a, None), (b, None), None)
|
||||
let assert_union = function
|
||||
| Union_t ((a, _), (b, _), _) -> (a, b)
|
||||
| _ -> assert false
|
||||
|
||||
let pair a b = Pair_t ((a, None, None), (b, None, None), None)
|
||||
let assert_pair = function
|
||||
| Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b)
|
||||
| _ -> assert false
|
||||
let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with
|
||||
| Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b)
|
||||
| _ -> raise (Failure msg)
|
||||
|
||||
let unit = Unit_t None
|
||||
|
||||
let bytes = Bytes_t None
|
||||
let bytes_k = Bytes_key None
|
||||
|
||||
let nat = Nat_t None
|
||||
let tez = Mutez_t None
|
||||
let int = Int_t None
|
||||
let nat_k = Nat_key None
|
||||
let tez_k = Mutez_key None
|
||||
let int_k = Int_key None
|
||||
|
||||
let big_map k v = Big_map_t (k, v, None)
|
||||
|
||||
let signature = Signature_t None
|
||||
let operation = Operation_t None
|
||||
|
||||
let bool = Bool_t None
|
||||
|
||||
let mutez = Mutez_t None
|
||||
|
||||
let string = String_t None
|
||||
let string_k = String_key None
|
||||
let address_k = Address_key None
|
||||
|
||||
let key = Key_t None
|
||||
|
||||
let list a = List_t (a, None)
|
||||
let set a = Set_t (a, None)
|
||||
let assert_list = function
|
||||
| List_t (a, _) -> a
|
||||
| _ -> assert false
|
||||
|
||||
let option a = Option_t ((a, None), None, None)
|
||||
let contract a = Contract_t (a, None)
|
||||
let assert_option = function
|
||||
| Option_t ((a, _), _, _) -> a
|
||||
| _ -> assert false
|
||||
|
||||
let address = Address_t None
|
||||
|
||||
let lambda a b = Lambda_t (a, b, None)
|
||||
let assert_lambda = function
|
||||
| Lambda_t (a, b, _) -> (a, b)
|
||||
| _ -> assert false
|
||||
type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda
|
||||
let is_lambda : type a . a ty -> ex_lambda option = function
|
||||
| Lambda_t (_, _, _) as x -> Some (Ex_lambda x)
|
||||
| _ -> None
|
||||
|
||||
let timestamp = Timestamp_t None
|
||||
let timestamp_k = Timestamp_key None
|
||||
|
||||
let map a b = Map_t (a, b, None)
|
||||
|
||||
let assert_type (_:'a ty) (_:'a) = ()
|
||||
end
|
||||
|
||||
module Values = struct
|
||||
let empty_map t = empty_map t
|
||||
|
||||
let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = {
|
||||
key_type ; value_type ; diff = empty_map comparable_key_ty ;
|
||||
}
|
||||
|
||||
let int n = Script_int.of_int n
|
||||
|
||||
let nat n = Script_int.abs @@ Script_int.of_int n
|
||||
let nat_to_int n = Option.unopt_exn @@ Script_int.to_int n
|
||||
|
||||
let tez n = Option.unopt_exn @@ Tez.of_mutez @@ Int64.of_int n
|
||||
|
||||
let left a = L a
|
||||
|
||||
let right b = R b
|
||||
end
|
||||
@ -1,11 +0,0 @@
|
||||
(library
|
||||
(name meta_michelson)
|
||||
(public_name ligo.meta_michelson)
|
||||
(libraries
|
||||
simple-utils
|
||||
tezos-utils
|
||||
proto-alpha-utils
|
||||
michelson-parser
|
||||
tezos-micheline
|
||||
)
|
||||
)
|
||||
@ -1,7 +0,0 @@
|
||||
let force_record ~msg json = match json with
|
||||
| `O json -> json
|
||||
| _ -> raise @@ Failure ("not json record : " ^ msg)
|
||||
|
||||
let force_string ~msg json = match json with
|
||||
| `String str -> str
|
||||
| _ -> raise @@ Failure ("not json str : " ^ msg)
|
||||
@ -1,12 +0,0 @@
|
||||
module Run = struct
|
||||
open Contract
|
||||
let run_lwt_full = run_lwt_full
|
||||
let run_lwt = run_lwt
|
||||
let run_str = run_str
|
||||
let run_node = run_node
|
||||
let run = run
|
||||
end
|
||||
module Stack = Michelson_wrap.Stack
|
||||
module Values = Contract.Values
|
||||
module Types = Contract.Types
|
||||
|
||||
@ -1,514 +0,0 @@
|
||||
open Proto_alpha_utils.Memory_proto_alpha
|
||||
module AC = Alpha_context
|
||||
|
||||
module Types = Contract.Types
|
||||
module Option = Simple_utils.Option
|
||||
module MBytes = Alpha_environment.MBytes
|
||||
|
||||
module Stack = struct
|
||||
open Script_typed_ir
|
||||
|
||||
let descr bef aft instr =
|
||||
{
|
||||
loc = 0 ;
|
||||
bef ; aft ; instr
|
||||
}
|
||||
|
||||
type nonrec 'a ty = 'a ty
|
||||
type 'a t = 'a stack_ty
|
||||
type nonrec ('a, 'b) descr = ('a, 'b) descr
|
||||
type ('a, 'b) code = ('a t) -> ('a, 'b) descr
|
||||
|
||||
type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty
|
||||
type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr
|
||||
type ex_code = Ex_code : ('a, 'b) code -> ex_code
|
||||
|
||||
let stack ?annot a b = Item_t (a, b, annot)
|
||||
let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) =
|
||||
let Item_t (hd, tl, _) = item in
|
||||
(hd, tl)
|
||||
|
||||
let nil = Empty_t
|
||||
let head x = fst @@ unstack x
|
||||
let tail x = snd @@ unstack x
|
||||
|
||||
let seq a b bef =
|
||||
let a_descr = a bef in
|
||||
let b_descr = b a_descr.aft in
|
||||
let aft = b_descr.aft in
|
||||
descr bef aft @@ Seq (a_descr, b_descr)
|
||||
|
||||
let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack
|
||||
let (@|) = seq
|
||||
let (@:) = stack
|
||||
|
||||
let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d
|
||||
|
||||
let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack
|
||||
|
||||
let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc ->
|
||||
descr ab.bef bc.aft @@ Seq(ab, bc)
|
||||
|
||||
let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr =
|
||||
let bc_descr = code ab_descr.aft in
|
||||
ab_descr <:: bc_descr
|
||||
|
||||
end
|
||||
|
||||
open Stack
|
||||
|
||||
type nat = AC.Script_int.n AC.Script_int.num
|
||||
type int_num = AC.Script_int.z AC.Script_int.num
|
||||
type bytes = MBytes.t
|
||||
type address = AC.Contract.t Script_typed_ir.ty
|
||||
type mutez = AC.Tez.t Script_typed_ir.ty
|
||||
|
||||
|
||||
module Stack_ops = struct
|
||||
open Script_typed_ir
|
||||
let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef ->
|
||||
let Item_t (ty, rest, _) = bef in
|
||||
descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup
|
||||
|
||||
let drop : ('a * 'rest, 'rest) code = fun bef ->
|
||||
let aft = snd @@ unstack bef in
|
||||
descr bef aft Drop
|
||||
|
||||
let swap (bef : (('a * ('b * 'c)) stack_ty)) =
|
||||
let Item_t (a, Item_t (b, rest, _), _) = bef in
|
||||
descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap
|
||||
|
||||
let dip code (bef : ('ty * 'rest) stack_ty) =
|
||||
let Item_t (ty, rest, _) = bef in
|
||||
let applied = code rest in
|
||||
let aft = Item_t (ty, applied.aft, None) in
|
||||
descr bef aft (Dip (code rest))
|
||||
|
||||
let noop : ('r, 'r) code = fun bef ->
|
||||
descr bef bef Nop
|
||||
|
||||
let exec : (_, _) code = fun bef ->
|
||||
let lambda = head @@ tail bef in
|
||||
let (_, ret) = Types.assert_lambda lambda in
|
||||
let aft = ret @: (tail @@ tail bef) in
|
||||
descr bef aft Exec
|
||||
|
||||
let fail aft : ('a * 'r, 'b) code = fun bef ->
|
||||
let head = fst @@ unstack bef in
|
||||
descr bef aft (Failwith head)
|
||||
|
||||
let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr =
|
||||
let aft = Item_t (Types.string, bef, None) in
|
||||
descr bef aft (Const (str))
|
||||
|
||||
let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r ->
|
||||
let aft = stack (Types.option a) r in
|
||||
descr r aft (Const None)
|
||||
|
||||
let push_unit : ('rest, unit * 'rest) code = fun r ->
|
||||
let aft = stack Types.unit r in
|
||||
descr r aft (Const ())
|
||||
|
||||
let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr =
|
||||
let aft = Item_t (Types.nat, bef, None) in
|
||||
descr bef aft (Const (Contract.Values.nat n))
|
||||
|
||||
let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr =
|
||||
let aft = Types.int @: bef in
|
||||
descr bef aft (Const (Contract.Values.int n))
|
||||
|
||||
let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr =
|
||||
let aft = Types.mutez @: bef in
|
||||
descr bef aft (Const (Contract.Values.tez n))
|
||||
|
||||
let push_bool b : ('s, bool * 's) code = fun bef ->
|
||||
let aft = stack Types.bool bef in
|
||||
descr bef aft (Const b)
|
||||
|
||||
let push_generic ty v : ('s, _ * 's) code = fun bef ->
|
||||
let aft = stack ty bef in
|
||||
descr bef aft (Const v)
|
||||
|
||||
let failstring str aft =
|
||||
push_string str @| fail aft
|
||||
|
||||
end
|
||||
|
||||
module Stack_shortcuts = struct
|
||||
open Stack_ops
|
||||
|
||||
let diip c x = dip (dip c) x
|
||||
let diiip c x = dip (diip c) x
|
||||
let diiiip c x = dip (diiip c) x
|
||||
|
||||
let bubble_1 = swap
|
||||
let bubble_down_1 = swap
|
||||
|
||||
let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef ->
|
||||
bef <. dip swap <: swap
|
||||
let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef ->
|
||||
bef <. swap <: dip swap
|
||||
|
||||
let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef ->
|
||||
bef <. diip swap <: dip swap <: swap
|
||||
|
||||
let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef ->
|
||||
bef <. dup <: dip code
|
||||
|
||||
let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s ->
|
||||
s <. keep_1 code <: swap
|
||||
|
||||
let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef ->
|
||||
(dup @| dip (swap @| dup @| dip (swap @| code))) bef
|
||||
|
||||
let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef ->
|
||||
(dip dup @| swap @| dip code) bef
|
||||
|
||||
let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s ->
|
||||
let aft = head d.aft @: tail s in
|
||||
descr s aft d.instr
|
||||
|
||||
end
|
||||
|
||||
module Pair_ops = struct
|
||||
let car (bef : (('a * 'b) * 'rest) Stack.t) =
|
||||
let (pair, rest) = unstack bef in
|
||||
let (a, _) = Contract.Types.assert_pair pair in
|
||||
descr bef (stack a rest) Car
|
||||
|
||||
let cdr (bef : (('a * 'b) * 'rest) Stack.t) =
|
||||
let (pair, rest) = unstack bef in
|
||||
let (_, b) = Contract.Types.assert_pair pair in
|
||||
descr bef (stack b rest) Cdr
|
||||
|
||||
let pair (bef : ('a * ('b * 'rest)) Stack.t) =
|
||||
let (a, rest) = unstack bef in
|
||||
let (b, rest) = unstack rest in
|
||||
let aft = (Types.pair a b) @: rest in
|
||||
descr bef aft Cons_pair
|
||||
|
||||
open Stack_ops
|
||||
let carcdr s = s <. car <: Stack_ops.dip cdr
|
||||
|
||||
let cdrcar s = s <. cdr <: dip car
|
||||
|
||||
let cdrcdr s = s <. cdr <: dip cdr
|
||||
|
||||
let carcar s = s <. car <: dip car
|
||||
|
||||
let cdar s = s <. cdr <: car
|
||||
|
||||
let unpair s = s <. dup <: car <: dip cdr
|
||||
end
|
||||
|
||||
module Option_ops = struct
|
||||
open Script_typed_ir
|
||||
|
||||
let cons bef =
|
||||
let (hd, tl) = unstack bef in
|
||||
descr bef (stack (Contract.Types.option hd) tl) Cons_some
|
||||
|
||||
let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef ->
|
||||
let (a_opt, base) = unstack bef in
|
||||
let a = Types.assert_option a_opt in
|
||||
let target = Option.unopt ~default:(none_branch base).aft target in
|
||||
descr bef target (If_none (none_branch base, some_branch (stack a base)))
|
||||
|
||||
let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s ->
|
||||
let (a_opt, base) = unstack s in
|
||||
let a = Types.assert_option a_opt in
|
||||
let target = a @: base in
|
||||
cond ~target
|
||||
(Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target)
|
||||
Stack_ops.noop s
|
||||
end
|
||||
|
||||
module Union_ops = struct
|
||||
open Script_typed_ir
|
||||
|
||||
let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef ->
|
||||
let (a, base) = unstack bef in
|
||||
let aft = Types.union a b @: base in
|
||||
descr bef aft Left
|
||||
|
||||
let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef ->
|
||||
let (b, base) = unstack bef in
|
||||
let aft = Types.union a b @: base in
|
||||
descr bef aft Right
|
||||
|
||||
|
||||
let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef ->
|
||||
let (union, base) = unstack bef in
|
||||
let (a, b) = Types.assert_union union in
|
||||
let code_stack = a @: base in
|
||||
let aft = Option.unopt ~default:(b @: base) after in
|
||||
descr bef aft (Loop_left (code code_stack))
|
||||
|
||||
end
|
||||
|
||||
module Arithmetic = struct
|
||||
let neq : (int_num * 'r, bool *'r) code = fun bef ->
|
||||
let aft = stack Types.bool @@ snd @@ unstack bef in
|
||||
descr bef aft Neq
|
||||
|
||||
let neg : (int_num * 'r, int_num *'r) code = fun bef ->
|
||||
let aft = stack Types.int @@ snd @@ unstack bef in
|
||||
descr bef aft Neg_int
|
||||
|
||||
let abs : (int_num * 'r, nat *'r) code = fun bef ->
|
||||
let aft = stack Types.nat @@ snd @@ unstack bef in
|
||||
descr bef aft Abs_int
|
||||
|
||||
let int : (nat * 'r, int_num*'r) code = fun bef ->
|
||||
let aft = stack Types.int @@ snd @@ unstack bef in
|
||||
descr bef aft Int_nat
|
||||
|
||||
let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef ->
|
||||
let aft = stack Types.(option nat) @@ tail bef in
|
||||
descr bef aft Is_nat
|
||||
|
||||
let nat_neq = fun s -> (int @| neq) s
|
||||
|
||||
let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
|
||||
let (nat, rest) = unstack bef in
|
||||
let rest = tail rest in
|
||||
let aft = stack nat rest in
|
||||
descr bef aft Add_natnat
|
||||
|
||||
let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
|
||||
let (nat, rest) = unstack bef in
|
||||
let rest = tail rest in
|
||||
let aft = stack nat rest in
|
||||
descr bef aft Add_intint
|
||||
|
||||
let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef ->
|
||||
let aft = tail bef in
|
||||
descr bef aft Add_tez
|
||||
|
||||
let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) =
|
||||
let nat = head bef in
|
||||
let rest = tail @@ tail bef in
|
||||
let aft = stack nat rest in
|
||||
descr bef aft Mul_natnat
|
||||
|
||||
let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) =
|
||||
let nat = head bef in
|
||||
let rest = tail @@ tail bef in
|
||||
let aft = stack nat rest in
|
||||
descr bef aft Mul_intint
|
||||
|
||||
let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef ->
|
||||
let aft = tail bef in
|
||||
descr bef aft Sub_int
|
||||
|
||||
let sub_natnat : (nat * (nat * 'r), int_num * 'r) code =
|
||||
fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint
|
||||
|
||||
let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s ->
|
||||
let (n, base) = unstack @@ snd @@ unstack s in
|
||||
let aft = Types.option (Types.pair n n) @: base in
|
||||
descr s aft Ediv_natnat
|
||||
|
||||
let ediv_tez = fun s ->
|
||||
let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in
|
||||
descr s aft Ediv_teznat
|
||||
|
||||
open Option_ops
|
||||
let force_ediv x = x <. ediv <: force_some
|
||||
let force_ediv_tez x = (ediv_tez @| force_some) x
|
||||
|
||||
open Pair_ops
|
||||
let div x = x <. force_ediv <: car
|
||||
|
||||
open Stack_ops
|
||||
let div_n n s = s <. push_nat n <: swap <: div
|
||||
let add_n n s = s <. push_nat n <: swap <: add_natnat
|
||||
let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez
|
||||
let sub_n n s = s <. push_nat n <: swap <: sub_natnat
|
||||
|
||||
let force_nat s = s <. nat_opt <: force_some ~msg:"force nat"
|
||||
end
|
||||
|
||||
module Boolean = struct
|
||||
let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef ->
|
||||
let aft = Types.bool @: tail @@ tail bef in
|
||||
descr bef aft And
|
||||
|
||||
let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef ->
|
||||
let aft = Types.bool @: tail @@ tail bef in
|
||||
descr bef aft Or
|
||||
|
||||
open Script_typed_ir
|
||||
let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef ->
|
||||
let base = tail bef in
|
||||
let aft = Option.unopt ~default:((true_branch base).aft) target in
|
||||
descr bef aft (If (true_branch base, false_branch base))
|
||||
|
||||
let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef ->
|
||||
let aft = tail bef in
|
||||
descr bef aft @@ Loop (code aft)
|
||||
|
||||
end
|
||||
|
||||
module Comparison_ops = struct
|
||||
let cmp c_ty : _ code = fun bef ->
|
||||
let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in
|
||||
descr bef aft (Compare c_ty)
|
||||
|
||||
let cmp_bytes = fun x -> cmp (Bytes_key None) x
|
||||
|
||||
let eq : (int_num * 'r, bool *'r) code = fun bef ->
|
||||
let aft = stack Contract.Types.bool @@ snd @@ unstack bef in
|
||||
descr bef aft Eq
|
||||
|
||||
open Arithmetic
|
||||
let eq_n n s = s <. sub_n n <: eq
|
||||
|
||||
let ge : (int_num * 'r, bool * 'r) code = fun bef ->
|
||||
let base = tail bef in
|
||||
let aft = stack Types.bool base in
|
||||
descr bef aft Ge
|
||||
|
||||
let gt : (int_num * 'r, bool * 'r) code = fun bef ->
|
||||
let base = tail bef in
|
||||
let aft = stack Types.bool base in
|
||||
descr bef aft Gt
|
||||
|
||||
let lt : (int_num * 'r, bool * 'r) code = fun bef ->
|
||||
let base = tail bef in
|
||||
let aft = stack Types.bool base in
|
||||
descr bef aft Lt
|
||||
|
||||
let gt_nat s = s <. int <: gt
|
||||
|
||||
open Stack_ops
|
||||
let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s)
|
||||
|
||||
let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef ->
|
||||
bef <. sub_natnat <: ge
|
||||
|
||||
let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef ->
|
||||
bef <. cmp Types.timestamp_k <: ge
|
||||
|
||||
let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef ->
|
||||
bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef))
|
||||
|
||||
let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef ->
|
||||
bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef))
|
||||
end
|
||||
|
||||
|
||||
module Bytes = struct
|
||||
|
||||
open Script_typed_ir
|
||||
|
||||
let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef ->
|
||||
let aft = stack Types.bytes @@ tail bef in
|
||||
descr bef aft (Pack ty)
|
||||
|
||||
let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef ->
|
||||
let aft = stack (Types.option ty) (tail bef) in
|
||||
descr bef aft (Unpack ty)
|
||||
|
||||
let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some
|
||||
|
||||
let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef ->
|
||||
let aft = tail bef in
|
||||
descr bef aft Concat_bytes_pair
|
||||
|
||||
let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
|
||||
descr bef bef Sha256
|
||||
|
||||
let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef ->
|
||||
descr bef bef Blake2b
|
||||
end
|
||||
|
||||
|
||||
module Map = struct
|
||||
open Script_typed_ir
|
||||
|
||||
type ('a, 'b) t = ('a, 'b) map
|
||||
|
||||
let empty c_ty = Script_ir_translator.empty_map c_ty
|
||||
let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m
|
||||
|
||||
module Ops = struct
|
||||
let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr =
|
||||
let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in
|
||||
let aft = Item_t (map, rest, None) in
|
||||
descr bef aft Map_update
|
||||
|
||||
let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef ->
|
||||
let _ = a in
|
||||
let base = snd @@ unstack @@ snd @@ unstack bef in
|
||||
let aft = stack (Types.option b) base in
|
||||
descr bef aft Map_get
|
||||
|
||||
let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef ->
|
||||
let base = snd @@ unstack @@ snd @@ unstack bef in
|
||||
let aft = stack (Types.option b) base in
|
||||
descr bef aft Big_map_get
|
||||
|
||||
let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef ->
|
||||
let base = tail @@ tail bef in
|
||||
descr bef base Big_map_update
|
||||
end
|
||||
end
|
||||
|
||||
module List_ops = struct
|
||||
let nil ele bef =
|
||||
let aft = stack (Types.list ele) bef in
|
||||
descr bef aft Nil
|
||||
|
||||
let cons bef =
|
||||
let aft = tail bef in
|
||||
descr bef aft Cons_list
|
||||
|
||||
let cond ~target cons_branch nil_branch bef =
|
||||
let (lst, aft) = unstack bef in
|
||||
let a = Types.assert_list lst in
|
||||
let cons_descr = cons_branch (a @: Types.list a @: aft) in
|
||||
let nil_descr = nil_branch aft in
|
||||
descr bef target (If_cons (cons_descr, nil_descr))
|
||||
|
||||
let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef ->
|
||||
let (a_lst, aft) = unstack bef in
|
||||
let a = Types.assert_list a_lst in
|
||||
descr bef aft (List_iter (code (a @: aft)))
|
||||
|
||||
end
|
||||
|
||||
module Tez = struct
|
||||
|
||||
let amount : ('r, AC.Tez.t * 'r) code = fun bef ->
|
||||
let aft = Types.mutez @: bef in
|
||||
descr bef aft Amount
|
||||
|
||||
open Bytes
|
||||
|
||||
let tez_nat s = s <. pack Types.mutez <: unpack Types.nat
|
||||
let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat
|
||||
end
|
||||
|
||||
module Misc = struct
|
||||
|
||||
open Stack_ops
|
||||
open Stack_shortcuts
|
||||
open Comparison_ops
|
||||
let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s ->
|
||||
s <.
|
||||
keep_2 cmp_ge_nat <: bubble_2 <:
|
||||
Boolean.cond drop (dip drop)
|
||||
|
||||
let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop
|
||||
|
||||
let debug_msg msg = debug ~msg ()
|
||||
|
||||
let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef ->
|
||||
let aft = stack Types.timestamp bef in
|
||||
descr bef aft Now
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
@ -1,302 +0,0 @@
|
||||
module Signature = Tezos_base.TzPervasives.Signature
|
||||
open Proto_alpha_utils.Memory_proto_alpha
|
||||
module Data_encoding = Alpha_environment.Data_encoding
|
||||
module MBytes = Alpha_environment.MBytes
|
||||
module Error_monad = Proto_alpha_utils.Error_monad
|
||||
open Error_monad
|
||||
|
||||
module Context_init = struct
|
||||
|
||||
type account = {
|
||||
pkh : Signature.Public_key_hash.t ;
|
||||
pk : Signature.Public_key.t ;
|
||||
sk : Signature.Secret_key.t ;
|
||||
}
|
||||
|
||||
let generate_accounts n : (account * Tez_repr.t) list =
|
||||
let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
|
||||
List.map (fun _ ->
|
||||
let (pkh, pk, sk) = Signature.generate_key () in
|
||||
let account = { pkh ; pk ; sk } in
|
||||
account, amount)
|
||||
(Simple_utils.List.range n)
|
||||
|
||||
let make_shell
|
||||
~level ~predecessor ~timestamp ~fitness ~operations_hash =
|
||||
Tezos_base.Block_header.{
|
||||
level ;
|
||||
predecessor ;
|
||||
timestamp ;
|
||||
fitness ;
|
||||
operations_hash ;
|
||||
(* We don't care of the following values, only the shell validates them. *)
|
||||
proto_level = 0 ;
|
||||
validation_passes = 0 ;
|
||||
context = Alpha_environment.Context_hash.zero ;
|
||||
}
|
||||
|
||||
let default_proof_of_work_nonce =
|
||||
MBytes.create Alpha_context.Constants.proof_of_work_nonce_size
|
||||
|
||||
let protocol_param_key = [ "protocol_parameters" ]
|
||||
|
||||
let check_constants_consistency constants =
|
||||
let open Constants_repr in
|
||||
let open Error_monad in
|
||||
let { blocks_per_cycle ; blocks_per_commitment ;
|
||||
blocks_per_roll_snapshot ; _ } = constants in
|
||||
Error_monad.unless (blocks_per_commitment <= blocks_per_cycle)
|
||||
(fun () -> failwith "Inconsistent constants : blocks per commitment must be \
|
||||
less than blocks per cycle") >>=? fun () ->
|
||||
Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot)
|
||||
(fun () -> failwith "Inconsistent constants : blocks per cycle \
|
||||
must be superior than blocks per roll snapshot") >>=?
|
||||
return
|
||||
|
||||
|
||||
let initial_context
|
||||
constants
|
||||
header
|
||||
commitments
|
||||
initial_accounts
|
||||
security_deposit_ramp_up_cycles
|
||||
no_reward_cycles
|
||||
=
|
||||
let open Tezos_base.TzPervasives.Error_monad in
|
||||
let bootstrap_accounts =
|
||||
List.map (fun ({ pk ; pkh ; _ }, amount) ->
|
||||
let open! Parameters_repr in
|
||||
{ public_key_hash = pkh ; public_key = Some pk ; amount }
|
||||
) initial_accounts
|
||||
in
|
||||
let json =
|
||||
Data_encoding.Json.construct
|
||||
Parameters_repr.encoding
|
||||
Parameters_repr.{
|
||||
bootstrap_accounts ;
|
||||
bootstrap_contracts = [] ;
|
||||
commitments ;
|
||||
constants ;
|
||||
security_deposit_ramp_up_cycles ;
|
||||
no_reward_cycles ;
|
||||
}
|
||||
in
|
||||
let proto_params =
|
||||
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
|
||||
in
|
||||
Tezos_protocol_environment_memory.Context.(
|
||||
set empty ["version"] (MBytes.of_string "genesis")
|
||||
) >>= fun ctxt ->
|
||||
Tezos_protocol_environment_memory.Context.(
|
||||
set ctxt protocol_param_key proto_params
|
||||
) >>= fun ctxt ->
|
||||
Main.init ctxt header
|
||||
>|= Alpha_environment.wrap_error >>=? fun { context; _ } ->
|
||||
return context
|
||||
|
||||
let genesis
|
||||
?(preserved_cycles = Constants_repr.default.preserved_cycles)
|
||||
?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle)
|
||||
?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment)
|
||||
?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot)
|
||||
?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period)
|
||||
?(time_between_blocks = Constants_repr.default.time_between_blocks)
|
||||
?(endorsers_per_block = Constants_repr.default.endorsers_per_block)
|
||||
?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation)
|
||||
?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block)
|
||||
?(proof_of_work_threshold = Int64.(neg one))
|
||||
?(tokens_per_roll = Constants_repr.default.tokens_per_roll)
|
||||
?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size)
|
||||
?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip)
|
||||
?(origination_size = Constants_repr.default.origination_size)
|
||||
?(block_security_deposit = Constants_repr.default.block_security_deposit)
|
||||
?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit)
|
||||
?(block_reward = Constants_repr.default.block_reward)
|
||||
?(endorsement_reward = Constants_repr.default.endorsement_reward)
|
||||
?(cost_per_byte = Constants_repr.default.cost_per_byte)
|
||||
?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation)
|
||||
?(commitments = [])
|
||||
?(security_deposit_ramp_up_cycles = None)
|
||||
?(no_reward_cycles = None)
|
||||
(initial_accounts : (account * Tez_repr.t) list)
|
||||
=
|
||||
if initial_accounts = [] then
|
||||
Pervasives.failwith "Must have one account with a roll to bake";
|
||||
|
||||
(* Check there is at least one roll *)
|
||||
let open Tezos_base.TzPervasives.Error_monad in
|
||||
begin try
|
||||
let (>>?=) x y = match x with
|
||||
| Ok(a) -> y a
|
||||
| Error(b) -> fail @@ List.hd b in
|
||||
fold_left_s (fun acc (_, amount) ->
|
||||
Alpha_environment.wrap_error @@
|
||||
Tez_repr.(+?) acc amount >>?= fun acc ->
|
||||
if acc >= tokens_per_roll then
|
||||
raise Exit
|
||||
else return acc
|
||||
) Tez_repr.zero initial_accounts >>=? fun _ ->
|
||||
failwith "Insufficient tokens in initial accounts to create one roll"
|
||||
with Exit -> return ()
|
||||
end >>=? fun () ->
|
||||
|
||||
let constants : Constants_repr.parametric = {
|
||||
preserved_cycles ;
|
||||
blocks_per_cycle ;
|
||||
blocks_per_commitment ;
|
||||
blocks_per_roll_snapshot ;
|
||||
blocks_per_voting_period ;
|
||||
time_between_blocks ;
|
||||
endorsers_per_block ;
|
||||
hard_gas_limit_per_operation ;
|
||||
hard_gas_limit_per_block ;
|
||||
proof_of_work_threshold ;
|
||||
tokens_per_roll ;
|
||||
michelson_maximum_type_size ;
|
||||
seed_nonce_revelation_tip ;
|
||||
origination_size ;
|
||||
block_security_deposit ;
|
||||
endorsement_security_deposit ;
|
||||
block_reward ;
|
||||
endorsement_reward ;
|
||||
cost_per_byte ;
|
||||
hard_storage_limit_per_operation ;
|
||||
} in
|
||||
check_constants_consistency constants >>=? fun () ->
|
||||
|
||||
let hash =
|
||||
Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
|
||||
in
|
||||
let shell = make_shell
|
||||
~level:0l
|
||||
~predecessor:hash
|
||||
~timestamp:Tezos_utils.Time.epoch
|
||||
~fitness: (Fitness_repr.from_int64 0L)
|
||||
~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
|
||||
initial_context
|
||||
constants
|
||||
shell
|
||||
commitments
|
||||
initial_accounts
|
||||
security_deposit_ramp_up_cycles
|
||||
no_reward_cycles
|
||||
>>=? fun context ->
|
||||
return (context, shell, hash)
|
||||
|
||||
let init
|
||||
?(slow=false)
|
||||
?preserved_cycles
|
||||
?endorsers_per_block
|
||||
?commitments
|
||||
n =
|
||||
let open Error_monad in
|
||||
let accounts = generate_accounts n in
|
||||
let contracts = List.map (fun (a, _) ->
|
||||
Alpha_context.Contract.implicit_contract (a.pkh)) accounts in
|
||||
begin
|
||||
if slow then
|
||||
genesis
|
||||
?preserved_cycles
|
||||
?endorsers_per_block
|
||||
?commitments
|
||||
accounts
|
||||
else
|
||||
genesis
|
||||
?preserved_cycles
|
||||
~blocks_per_cycle:32l
|
||||
~blocks_per_commitment:4l
|
||||
~blocks_per_roll_snapshot:8l
|
||||
~blocks_per_voting_period:(Int32.mul 32l 8l)
|
||||
?endorsers_per_block
|
||||
?commitments
|
||||
accounts
|
||||
end >>=? fun ctxt ->
|
||||
return (ctxt, accounts, contracts)
|
||||
|
||||
let contents
|
||||
?(proof_of_work_nonce = default_proof_of_work_nonce)
|
||||
?(priority = 0) ?seed_nonce_hash () =
|
||||
Alpha_context.Block_header.({
|
||||
priority ;
|
||||
proof_of_work_nonce ;
|
||||
seed_nonce_hash ;
|
||||
})
|
||||
|
||||
|
||||
let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt =
|
||||
let contents = contents ~priority () in
|
||||
let protocol_data =
|
||||
let open! Alpha_context.Block_header in {
|
||||
contents ;
|
||||
signature = Signature.zero ;
|
||||
} in
|
||||
let header = {
|
||||
Alpha_context.Block_header.shell = {
|
||||
predecessor = hash ;
|
||||
proto_level = header.proto_level ;
|
||||
validation_passes = header.validation_passes ;
|
||||
fitness = header.fitness ;
|
||||
timestamp ;
|
||||
level = header.level ;
|
||||
context = Alpha_environment.Context_hash.zero ;
|
||||
operations_hash = Alpha_environment.Operation_list_list_hash.zero ;
|
||||
} ;
|
||||
protocol_data = {
|
||||
contents ;
|
||||
signature = Signature.zero ;
|
||||
} ;
|
||||
} in
|
||||
Main.begin_construction
|
||||
~chain_id: Alpha_environment.Chain_id.zero
|
||||
~predecessor_context: ctxt
|
||||
~predecessor_timestamp: header.shell.timestamp
|
||||
~predecessor_fitness: header.shell.fitness
|
||||
~predecessor_level: header.shell.level
|
||||
~predecessor:hash
|
||||
~timestamp
|
||||
~protocol_data
|
||||
() >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state ->
|
||||
return state.ctxt
|
||||
|
||||
let main n =
|
||||
init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
|
||||
let timestamp = Tezos_base.Time.now () in
|
||||
begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
|
||||
return (ctxt, accounts, contracts)
|
||||
|
||||
end
|
||||
|
||||
type identity = {
|
||||
public_key_hash : Signature.public_key_hash;
|
||||
public_key : Signature.public_key;
|
||||
secret_key : Signature.secret_key;
|
||||
implicit_contract : Alpha_context.Contract.t;
|
||||
}
|
||||
|
||||
type environment = {
|
||||
tezos_context : Alpha_context.t ;
|
||||
identities : identity list ;
|
||||
}
|
||||
|
||||
let init_environment () =
|
||||
Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) ->
|
||||
let accounts = List.map fst accounts in
|
||||
let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in
|
||||
let identities =
|
||||
List.map (fun ((a:Context_init.account), c) -> {
|
||||
public_key = a.pk ;
|
||||
public_key_hash = a.pkh ;
|
||||
secret_key = a.sk ;
|
||||
implicit_contract = c ;
|
||||
}) @@
|
||||
List.combine accounts contracts in
|
||||
return {tezos_context ; identities}
|
||||
|
||||
let contextualize ~msg ?environment f =
|
||||
let lwt =
|
||||
let environment = match environment with
|
||||
| None -> init_environment ()
|
||||
| Some x -> return x in
|
||||
environment >>=? f
|
||||
in
|
||||
force_ok ~msg @@ Lwt_main.run lwt
|
||||
@ -1,18 +0,0 @@
|
||||
let read_file f =
|
||||
let ic = open_in f in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
Bytes.to_string s
|
||||
|
||||
let read_lines filename =
|
||||
let lines = ref [] in
|
||||
let chan = open_in filename in
|
||||
try
|
||||
while true; do
|
||||
lines := input_line chan :: !lines
|
||||
done; !lines
|
||||
with End_of_file ->
|
||||
close_in chan;
|
||||
List.rev !lines
|
||||
@ -4,10 +4,9 @@
|
||||
(libraries
|
||||
simple-utils
|
||||
tezos-utils
|
||||
meta_michelson
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -51,7 +51,7 @@ type value =
|
||||
| D_set of value list
|
||||
(* | `Macro of anon_macro ... The future. *)
|
||||
| D_function of anon_function
|
||||
| D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
|
||||
| D_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
|
||||
|
||||
and selector = var_name list
|
||||
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
mini_c
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -10,7 +10,7 @@
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils -open Tezos_utils ))
|
||||
(preprocess
|
||||
(pps
|
||||
simple-utils.ppx_let_generalized
|
||||
ppx_let
|
||||
ppx_deriving.std
|
||||
)
|
||||
)
|
||||
@ -21,7 +21,7 @@
|
||||
(rule
|
||||
(targets parser.ml parser.mli)
|
||||
(deps parser_generated.mly ast.ml)
|
||||
(action (system "menhir --explain --external-tokens Lex.Token lex/token.mly parser_generated.mly --base parser"))
|
||||
(action (system "menhir --explain --unused-tokens --external-tokens Lex.Token lex/token.mly parser_generated.mly --base parser"))
|
||||
)
|
||||
|
||||
(rule
|
||||
|
||||
@ -4,12 +4,13 @@
|
||||
(libraries
|
||||
simple-utils
|
||||
tezos-utils
|
||||
parser_shared
|
||||
parser_pascaligo
|
||||
parser_camligo
|
||||
parser_ligodity
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared ))
|
||||
)
|
||||
|
||||
@ -15,6 +15,7 @@
|
||||
zarith
|
||||
simple-utils
|
||||
tezos-utils
|
||||
getopt
|
||||
)
|
||||
(flags (:standard -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -1,21 +0,0 @@
|
||||
before_script:
|
||||
- apt-get update -qq
|
||||
- apt-get -y -qq install libhidapi-dev libcap-dev bubblewrap
|
||||
- wget https://github.com/ocaml/opam/releases/download/2.0.1/opam-2.0.1-x86_64-linux -O opam-2.0.1-x86_64-linux
|
||||
- cp opam-2.0.1-x86_64-linux /usr/local/bin/opam
|
||||
- chmod +x /usr/local/bin/opam
|
||||
- export PATH="/usr/local/bin${PATH:+:}${PATH:-}"
|
||||
- echo "$PATH"
|
||||
- printf '' | opam init
|
||||
- eval $(opam config env)
|
||||
- opam repository add tezos-opam-repository https://gitlab.com/ligolang/tezos-opam-repository.git
|
||||
- eval $(opam config env)
|
||||
- opam --version
|
||||
- printf '' | ocaml
|
||||
|
||||
default-job:
|
||||
script:
|
||||
- opam install -y --working-dir .
|
||||
artifacts:
|
||||
paths:
|
||||
- Parser.exe
|
||||
@ -4,4 +4,18 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
|
||||
$HOME/git/ligo/src/parser/shared/Lexer.mli
|
||||
$HOME/git/ligo/src/parser/shared/Lexer.mll
|
||||
$HOME/git/ligo/src/parser/shared/Error.mli
|
||||
$HOME/git/ligo/src/parser/shared/EvalOpt.ml
|
||||
$HOME/git/ligo/src/parser/shared/EvalOpt.mli
|
||||
$HOME/git/ligo/src/parser/shared/FQueue.ml
|
||||
$HOME/git/ligo/src/parser/shared/FQueue.mli
|
||||
$HOME/git/ligo/src/parser/shared/LexerLog.mli
|
||||
$HOME/git/ligo/src/parser/shared/LexerLog.ml
|
||||
$HOME/git/ligo/src/parser/shared/Markup.ml
|
||||
$HOME/git/ligo/src/parser/shared/Markup.mli
|
||||
$HOME/git/ligo/src/parser/shared/Utils.mli
|
||||
$HOME/git/ligo/src/parser/shared/Utils.ml
|
||||
$HOME/git/ligo/src/parser/shared/Version.ml
|
||||
Stubs/Simple_utils.ml
|
||||
|
||||
@ -11,10 +11,6 @@ The directory contains the following:
|
||||
Tests
|
||||
The directory containing tests.
|
||||
|
||||
Version.ml
|
||||
A source containing a commit hash. It should be deleted, as Dune
|
||||
knows how to generate and updated version.
|
||||
|
||||
dune
|
||||
The Dune file for building the Pascaligo parser.
|
||||
|
||||
@ -46,11 +42,6 @@ The directory contains the following:
|
||||
build only a standalone lexer or a standalone parser. Do not
|
||||
change, unless you change EvalOpt and use Christian's build system.
|
||||
|
||||
LexerLog.ml
|
||||
LexerLog.mli
|
||||
Source for instantiating a standalone lexer for LexerMain.ml and
|
||||
ParserMain.ml. Ignore them.
|
||||
|
||||
ParserLog.mli
|
||||
ParserLog.ml
|
||||
Source for printing the AST. Used by ParserMain.ml, pascaligo.ml
|
||||
@ -65,51 +56,6 @@ The directory contains the following:
|
||||
AST.ml
|
||||
The abstract syntax tree of Pascaligo.
|
||||
|
||||
EvalOpt.mli
|
||||
EvalOpt.ml
|
||||
The module EvalOpt parses the command-line for options to the
|
||||
parser. That action is performed as a side-effect when the module
|
||||
is initialised at run-time: this is ugly and easy to fix. See
|
||||
ligo/src/parser/ligodity/EvalOpt.ml{i} for the right way to do
|
||||
it. Ignore them: the file actually calling directly the parser is
|
||||
ligo/src/parser/parser.ml. Note that, as a consequence, no option
|
||||
is currently passed to the parser when building Pascaligo with
|
||||
Dune. This should be made available.
|
||||
|
||||
Markup.mli
|
||||
Markup.ml
|
||||
The definition of markup in Pascaligo source files, and some some
|
||||
functions to print or convert it to strings. You are unlikely
|
||||
going to modify those files, as markup is pretty much the same for
|
||||
all LIGO flavours.
|
||||
|
||||
FQueue.mli
|
||||
FQueue.ml
|
||||
A naive implementation of purely functional queues. Replace by an
|
||||
imperative implementation if worst-case performance of single
|
||||
operations (queue/enqueue) is an issue.
|
||||
|
||||
Error.mli
|
||||
The definition of the open type for errors: the lexer will add its
|
||||
own errors, the downside being that matching on errors requires a
|
||||
catch-all clause "| _ -> assert false" at the end. Note: the rest
|
||||
of the compiler uses an error monad.
|
||||
|
||||
Lexer.mli
|
||||
Lexer.mll
|
||||
The Pascaligo lexer is generated from two ocamllex
|
||||
specifications. Lexer.mll is the first-level lexer. It exports a
|
||||
functor [Make] parameterised over a module [Token] defining the
|
||||
tokens, and returning a module whose signature is [Lexer.S]. (See
|
||||
Lexer.mli for a rationale.) If you write a new flavour of LIGO,
|
||||
this lexer is likely to be reused as is. Note that a great deal of
|
||||
the complexity of this lexer stems from its purpose to report
|
||||
stylistic errors (hence keeping temporarily scanned markup) and
|
||||
handling UTF-8 encoded comments. The first goal implies sometimes
|
||||
reading more than one token, and an extra-buffer has to be managed
|
||||
above the ocamllex one, so the parser is not confused about the
|
||||
location (region) of the token it has just read.
|
||||
|
||||
LexToken.mli
|
||||
LexToken.mll
|
||||
The second-level lexer of Pascaligo, scanning the (lexical)
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
(ocamllex LexToken)
|
||||
(ocamllex Lexer)
|
||||
|
||||
(menhir
|
||||
(merge_into Parser)
|
||||
@ -9,17 +8,27 @@
|
||||
(library
|
||||
(name parser_pascaligo)
|
||||
(public_name ligo.parser.pascaligo)
|
||||
(modules AST FQueue Markup pascaligo Utils Version Lexer Error Parser ParserLog LexToken)
|
||||
(modules_without_implementation Error)
|
||||
(modules AST pascaligo Parser ParserLog LexToken)
|
||||
(libraries
|
||||
parser_shared
|
||||
hex
|
||||
str
|
||||
uutf
|
||||
zarith
|
||||
simple-utils
|
||||
tezos-utils
|
||||
)
|
||||
(flags (:standard -open Simple_utils ))
|
||||
(flags (:standard -open Parser_shared -open Simple_utils))
|
||||
)
|
||||
|
||||
(executable
|
||||
(name LexerMain)
|
||||
(libraries
|
||||
hex
|
||||
simple-utils
|
||||
tezos-utils
|
||||
parser_pascaligo)
|
||||
(modules
|
||||
LexerMain
|
||||
)
|
||||
(flags (:standard -open Parser_shared -open Parser_pascaligo))
|
||||
)
|
||||
|
||||
;; Les deux directives (rule) qui suivent sont pour le dev local.
|
||||
@ -36,9 +45,3 @@
|
||||
; (deps LexerMain.exe)
|
||||
; (action (copy LexerMain.exe Lexer.exe))
|
||||
; (mode promote-until-clean))
|
||||
|
||||
(rule
|
||||
(targets Version.ml)
|
||||
(action
|
||||
(progn (run "sh" "-c" "printf 'let version = \"%s\"'\\\\n \"$(echo UNKNOWN)\" > Version.ml")))
|
||||
(mode promote-until-clean))
|
||||
|
||||
7
src/parser/shared/.links
Normal file
7
src/parser/shared/.links
Normal file
@ -0,0 +1,7 @@
|
||||
$HOME/git/OCaml-build/Makefile
|
||||
$HOME/git/OCaml-build/Makefile.cfg
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/pos.ml
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
|
||||
$HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
|
||||
55
src/parser/shared/Doc/shared.txt
Normal file
55
src/parser/shared/Doc/shared.txt
Normal file
@ -0,0 +1,55 @@
|
||||
INTERNAL DOCUMENTATION OF THE SHARED PARSER FUNCTIONALITY
|
||||
|
||||
Version.ml
|
||||
A source containing a commit hash. It should be deleted, as Dune
|
||||
knows how to generate and updated version.
|
||||
|
||||
EvalOpt.mli
|
||||
EvalOpt.ml
|
||||
The module EvalOpt parses the command-line for options to the
|
||||
parser. That action is performed as a side-effect when the module
|
||||
is initialised at run-time: this is ugly and easy to fix. See
|
||||
ligo/src/parser/ligodity/EvalOpt.ml{i} for the right way to do
|
||||
it. Ignore them: the file actually calling directly the parser is
|
||||
ligo/src/parser/parser.ml. Note that, as a consequence, no option
|
||||
is currently passed to the parser when building Pascaligo with
|
||||
Dune. This should be made available.
|
||||
|
||||
Markup.mli
|
||||
Markup.ml
|
||||
The definition of markup in source files, and some functions to
|
||||
print or convert it to strings. You are unlikely going to modify
|
||||
those files, as markup is pretty much the same for all LIGO
|
||||
flavours.
|
||||
|
||||
FQueue.mli
|
||||
FQueue.ml
|
||||
A naive implementation of purely functional queues. Replace by an
|
||||
imperative implementation if worst-case performance of single
|
||||
operations (queue/enqueue) is an issue.
|
||||
|
||||
Error.mli
|
||||
The definition of the open type for errors: the lexer will add its
|
||||
own errors, the downside being that matching on errors requires a
|
||||
catch-all clause "| _ -> assert false" at the end. Note: the rest
|
||||
of the compiler uses an error monad.
|
||||
|
||||
Lexer.mli
|
||||
Lexer.mll
|
||||
The Pascaligo lexer is generated from two ocamllex
|
||||
specifications. Lexer.mll is the first-level lexer. It exports a
|
||||
functor [Make] parameterised over a module [Token] defining the
|
||||
tokens, and returning a module whose signature is [Lexer.S]. (See
|
||||
Lexer.mli for a rationale.) If you write a new flavour of LIGO,
|
||||
this lexer is likely to be reused as is. Note that a great deal of
|
||||
the complexity of this lexer stems from its purpose to report
|
||||
stylistic errors (hence keeping temporarily scanned markup) and
|
||||
handling UTF-8 encoded comments. The first goal implies sometimes
|
||||
reading more than one token, and an extra-buffer has to be managed
|
||||
above the ocamllex one, so the parser is not confused about the
|
||||
location (region) of the token it has just read.
|
||||
|
||||
LexerLog.ml
|
||||
LexerLog.mli
|
||||
Source for instantiating a standalone lexer for LexerMain.ml and
|
||||
ParserMain.ml. Ignore them.
|
||||
28
src/parser/shared/dune
Normal file
28
src/parser/shared/dune
Normal file
@ -0,0 +1,28 @@
|
||||
(ocamllex Lexer)
|
||||
|
||||
(library
|
||||
(name parser_shared)
|
||||
(public_name ligo.parser.shared)
|
||||
(libraries
|
||||
simple-utils
|
||||
uutf
|
||||
getopt
|
||||
)
|
||||
(modules
|
||||
Error
|
||||
Lexer
|
||||
LexerLog
|
||||
Utils
|
||||
Markup
|
||||
FQueue
|
||||
EvalOpt
|
||||
Version
|
||||
)
|
||||
(modules_without_implementation Error)
|
||||
)
|
||||
|
||||
(rule
|
||||
(targets Version.ml)
|
||||
(action
|
||||
(progn (run "sh" "-c" "printf 'let version = \"%s\"'\\\\n \"$(echo UNKNOWN)\" > Version.ml")))
|
||||
(mode promote-until-clean))
|
||||
@ -10,7 +10,7 @@
|
||||
(modules ligodity pascaligo simplify)
|
||||
(preprocess
|
||||
(pps
|
||||
simple-utils.ppx_let_generalized
|
||||
ppx_let
|
||||
)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
|
||||
@ -75,13 +75,13 @@ let (first_owner , first_contract) =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let id = List.nth dummy_environment.identities 0 in
|
||||
let kt = id.implicit_contract in
|
||||
Alpha_context.Contract.to_b58check kt , kt
|
||||
Protocol.Alpha_context.Contract.to_b58check kt , kt
|
||||
|
||||
let second_owner =
|
||||
let open Proto_alpha_utils.Memory_proto_alpha in
|
||||
let id = List.nth dummy_environment.identities 1 in
|
||||
let kt = id.implicit_contract in
|
||||
Alpha_context.Contract.to_b58check kt
|
||||
Protocol.Alpha_context.Contract.to_b58check kt
|
||||
|
||||
let basic a b cards next_id =
|
||||
let card_patterns = List.map card_pattern_ez [
|
||||
@ -113,13 +113,13 @@ let buy () =
|
||||
let%bind () =
|
||||
let%bind amount =
|
||||
trace_option (simple_error "getting amount for run") @@
|
||||
Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in
|
||||
expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in
|
||||
let%bind () =
|
||||
let%bind amount =
|
||||
trace_option (simple_error "getting amount for run") @@
|
||||
Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in
|
||||
trace_strong (simple_error "could buy without money") @@
|
||||
Assert.assert_fail
|
||||
@ -152,13 +152,13 @@ let dispatch_buy () =
|
||||
let%bind () =
|
||||
let%bind amount =
|
||||
trace_option (simple_error "getting amount for run") @@
|
||||
Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in
|
||||
expect_eq_n_pos_small ~options program "main" make_input make_expected in
|
||||
let%bind () =
|
||||
let%bind amount =
|
||||
trace_option (simple_error "getting amount for run") @@
|
||||
Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount () in
|
||||
trace_strong (simple_error "could buy without money") @@
|
||||
Assert.assert_fail
|
||||
@ -190,7 +190,7 @@ let transfer () =
|
||||
e_pair ops storage
|
||||
in
|
||||
let%bind () =
|
||||
let amount = Memory_proto_alpha.Alpha_context.Tez.zero in
|
||||
let amount = Memory_proto_alpha.Protocol.Alpha_context.Tez.zero in
|
||||
let payer = first_contract in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~payer () in
|
||||
expect_eq_n_strict_pos_small ~options program "transfer_single" make_input make_expected in
|
||||
@ -220,7 +220,7 @@ let sell () =
|
||||
Ast_simplified.Misc.assert_value_eq (expected_storage , storage)
|
||||
in
|
||||
let%bind () =
|
||||
let amount = Memory_proto_alpha.Alpha_context.Tez.zero in
|
||||
let amount = Memory_proto_alpha.Protocol.Alpha_context.Tez.zero in
|
||||
let payer = first_contract in
|
||||
let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~amount ~payer () in
|
||||
expect_n_strict_pos_small ~options program "sell_single" make_input make_expecter in
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
alcotest
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -9,7 +9,7 @@
|
||||
operators
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
)
|
||||
|
||||
@ -9,7 +9,7 @@
|
||||
operators
|
||||
)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized)
|
||||
(pps ppx_let)
|
||||
)
|
||||
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
|
||||
)
|
||||
|
||||
2
urls.txt
2
urls.txt
@ -1 +1 @@
|
||||
repo 604d7d8c5eb209596f929225538c2c3c 420
|
||||
repo f9ec38c6d4dfb4ef9f64edb361326b32 420
|
||||
|
||||
2
vendors/ligo-utils/memory-proto-alpha/dune-project
vendored
Normal file
2
vendors/ligo-utils/memory-proto-alpha/dune-project
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
(lang dune 1.11)
|
||||
(name tezos-memory-proto-alpha)
|
||||
@ -1,8 +1,9 @@
|
||||
module Name = struct let name = "alpha" end
|
||||
module Alpha_environment = Tezos_protocol_environment_memory.MakeV1(Name)()
|
||||
module Alpha_environment = Tezos_protocol_alpha.Protocol.Environment
|
||||
|
||||
|
||||
type alpha_error = Alpha_environment.Error_monad.error
|
||||
type 'a alpha_tzresult = 'a Alpha_environment.Error_monad.tzresult
|
||||
module Alpha_error_monad = Alpha_environment.Error_monad
|
||||
module Proto = Tezos_protocol_alpha.Functor.Make(Alpha_environment)
|
||||
module Proto = Tezos_protocol_alpha
|
||||
include Proto
|
||||
195
vendors/ligo-utils/proto-alpha-utils/cast.ml
vendored
195
vendors/ligo-utils/proto-alpha-utils/cast.ml
vendored
@ -4,6 +4,7 @@ open Tezos_micheline
|
||||
let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment ()
|
||||
|
||||
open Memory_proto_alpha
|
||||
open Protocol
|
||||
open Alpha_context
|
||||
|
||||
exception Expr_from_string
|
||||
@ -44,6 +45,196 @@ let node_to_string (node:_ Micheline.node) =
|
||||
|
||||
open Script_ir_translator
|
||||
|
||||
type ex_typed_value =
|
||||
Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
|
||||
|
||||
include struct
|
||||
open Script_typed_ir
|
||||
open Protocol.Environment.Error_monad
|
||||
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
|
||||
open Micheline
|
||||
open Michelson_v1_primitives
|
||||
open Protocol.Environment
|
||||
|
||||
let rec unparse_data_generic
|
||||
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
|
||||
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
||||
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
||||
mapper (Ex_typed_value (ty, a)) >>=? function
|
||||
| Some x -> return (x, ctxt)
|
||||
| None -> (
|
||||
match ty, a with
|
||||
| Unit_t _, () ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_Unit, [], []), ctxt)
|
||||
| Int_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| Nat_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| String_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
|
||||
return (String (-1, s), ctxt)
|
||||
| Bytes_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, s), ctxt)
|
||||
| Bool_t _, true ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_True, [], []), ctxt)
|
||||
| Bool_t _, false ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_False, [], []), ctxt)
|
||||
| Timestamp_t _, t ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Readable ->
|
||||
match Script_timestamp.to_notation t with
|
||||
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Some s -> return (String (-1, s), ctxt)
|
||||
end
|
||||
| Address_t _, c ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Contract_t _, (_, c) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Signature_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.to_b58check s), ctxt)
|
||||
end
|
||||
| Mutez_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
|
||||
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
|
||||
| Key_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
|
||||
end
|
||||
| Key_hash_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
||||
end
|
||||
| Operation_t _, op ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
||||
| Union_t ((tl, _), _, _), L l ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
||||
| Union_t (_, (tr, _), _), R r ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
||||
| Option_t ((t, _), _, _), Some v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) ->
|
||||
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
||||
| Option_t _, None ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_None, [], []), ctxt)
|
||||
| List_t (t, _), items ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) element ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) ->
|
||||
return (unparsed :: l, ctxt))
|
||||
([], ctxt)
|
||||
items >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, List.rev items), ctxt)
|
||||
| Set_t (t, _), set ->
|
||||
let t = ty_of_comparable_ty t in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt)
|
||||
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Map_t (kt, vt, _), map ->
|
||||
let kt = ty_of_comparable_ty kt in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) (k, v) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) ->
|
||||
unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) ->
|
||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||
([], ctxt)
|
||||
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Big_map_t (_kt, _kv, _), _map ->
|
||||
return (Micheline.Seq (-1, []), ctxt)
|
||||
| Lambda_t _, Lam (_, original_code) ->
|
||||
unparse_code_generic ~mapper ctxt mode (root original_code)
|
||||
)
|
||||
|
||||
and unparse_code_generic ctxt ?mapper mode = function
|
||||
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
|
||||
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) ->
|
||||
parse_data ctxt t data >>=? fun (data, ctxt) ->
|
||||
unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
|
||||
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
|
||||
| Seq (loc, items) ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
|
||||
return (Micheline.Seq (loc, List.rev items), ctxt)
|
||||
| Prim (loc, prim, items, annot) ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
|
||||
return (Prim (loc, prim, List.rev items, annot), ctxt)
|
||||
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
|
||||
|
||||
|
||||
end
|
||||
|
||||
let rec mapper (Ex_typed_value (ty, a)) =
|
||||
let open Alpha_environment.Error_monad in
|
||||
let open Script_typed_ir in
|
||||
@ -67,7 +258,7 @@ let rec mapper (Ex_typed_value (ty, a)) =
|
||||
|
||||
and data_to_node (Ex_typed_value (ty, data)) =
|
||||
let tc = env.tezos_context in
|
||||
let node_lwt = Script_ir_translator.unparse_data tc ~mapper Readable ty data in
|
||||
let node_lwt = unparse_data_generic tc ~mapper Readable ty data in
|
||||
let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in
|
||||
node
|
||||
|
||||
@ -125,7 +316,7 @@ let descr_to_node x =
|
||||
| Car -> prim I_CAR
|
||||
| Cdr -> prim I_CDR
|
||||
| Cons_pair -> prim I_PAIR
|
||||
| Nop -> prim I_NOP
|
||||
| Nop -> Micheline.Seq (0, [prim I_UNIT ; prim I_DROP])
|
||||
| Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b])
|
||||
| Const v -> (
|
||||
let (Item_t (ty, _, _)) = descr.aft in
|
||||
|
||||
1
vendors/ligo-utils/proto-alpha-utils/dune
vendored
1
vendors/ligo-utils/proto-alpha-utils/dune
vendored
@ -4,6 +4,7 @@
|
||||
(libraries
|
||||
tezos-error-monad
|
||||
tezos-stdlib-unix
|
||||
tezos-protocol-alpha-parameters
|
||||
tezos-memory-proto-alpha
|
||||
simple-utils
|
||||
tezos-utils
|
||||
|
||||
@ -4,7 +4,7 @@ module Data_encoding = Alpha_environment.Data_encoding
|
||||
module MBytes = Alpha_environment.MBytes
|
||||
module Error_monad = X_error_monad
|
||||
open Error_monad
|
||||
|
||||
open Protocol
|
||||
|
||||
|
||||
module Context_init = struct
|
||||
@ -85,10 +85,10 @@ module Context_init = struct
|
||||
let proto_params =
|
||||
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
|
||||
in
|
||||
Tezos_protocol_environment_memory.Context.(
|
||||
set empty ["version"] (MBytes.of_string "genesis")
|
||||
Tezos_protocol_environment.Context.(
|
||||
set Memory_context.empty ["version"] (MBytes.of_string "genesis")
|
||||
) >>= fun ctxt ->
|
||||
Tezos_protocol_environment_memory.Context.(
|
||||
Tezos_protocol_environment.Context.(
|
||||
set ctxt protocol_param_key proto_params
|
||||
) >>= fun ctxt ->
|
||||
Main.init ctxt header
|
||||
@ -141,7 +141,7 @@ module Context_init = struct
|
||||
with Exit -> return ()
|
||||
end >>=? fun () ->
|
||||
|
||||
let constants : Constants_repr.parametric = {
|
||||
let constants : Constants_repr.parametric = Tezos_protocol_alpha_parameters.Default_parameters.({
|
||||
preserved_cycles ;
|
||||
blocks_per_cycle ;
|
||||
blocks_per_commitment ;
|
||||
@ -162,7 +162,8 @@ module Context_init = struct
|
||||
endorsement_reward ;
|
||||
cost_per_byte ;
|
||||
hard_storage_limit_per_operation ;
|
||||
} in
|
||||
test_chain_duration = constants_mainnet.test_chain_duration ;
|
||||
}) in
|
||||
check_constants_consistency constants >>=? fun () ->
|
||||
|
||||
let hash =
|
||||
@ -171,7 +172,7 @@ module Context_init = struct
|
||||
let shell = make_shell
|
||||
~level:0l
|
||||
~predecessor:hash
|
||||
~timestamp:Tezos_base.TzPervasives.Time.epoch
|
||||
~timestamp:Tezos_base.TzPervasives.Time.Protocol.epoch
|
||||
~fitness: (Fitness_repr.from_int64 0L)
|
||||
~operations_hash: Alpha_environment.Operation_list_list_hash.zero in
|
||||
initial_context
|
||||
@ -246,7 +247,7 @@ module Context_init = struct
|
||||
|
||||
let main n =
|
||||
init n >>=? fun ((ctxt, header, hash), accounts, contracts) ->
|
||||
let timestamp = Tezos_base.Time.now () in
|
||||
let timestamp = Environment.Time.of_seconds @@ Int64.of_float @@ Unix.time () in
|
||||
begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt ->
|
||||
return (ctxt, accounts, contracts)
|
||||
|
||||
|
||||
@ -39,6 +39,7 @@ depends: [
|
||||
"tezos-data-encoding"
|
||||
"tezos-protocol-environment"
|
||||
"tezos-protocol-alpha"
|
||||
"tezos-protocol-alpha-parameters"
|
||||
"michelson-parser"
|
||||
"simple-utils"
|
||||
"tezos-utils"
|
||||
|
||||
@ -4,15 +4,940 @@ include Memory_proto_alpha
|
||||
let init_environment = Init_proto_alpha.init_environment
|
||||
let dummy_environment = Init_proto_alpha.dummy_environment
|
||||
|
||||
open X_error_monad
|
||||
|
||||
open Protocol
|
||||
open Script_typed_ir
|
||||
open Script_ir_translator
|
||||
open Script_interpreter
|
||||
|
||||
module X = struct
|
||||
open Alpha_context
|
||||
open Script_tc_errors
|
||||
open Alpha_environment.Error_monad
|
||||
let rec stack_ty_eq
|
||||
: type ta tb. context -> int -> ta stack_ty -> tb stack_ty ->
|
||||
((ta stack_ty, tb stack_ty) eq * context) tzresult
|
||||
= fun ctxt lvl ta tb ->
|
||||
match ta, tb with
|
||||
| Item_t (tva, ra, _), Item_t (tvb, rb, _) ->
|
||||
ty_eq ctxt tva tvb |>
|
||||
record_trace (Bad_stack_item lvl) >>? fun (Eq, ctxt) ->
|
||||
stack_ty_eq ctxt (lvl + 1) ra rb >>? fun (Eq, ctxt) ->
|
||||
(Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
|
||||
| Empty_t, Empty_t -> Ok (Eq, ctxt)
|
||||
| _, _ -> error Bad_stack_length
|
||||
|
||||
open Script_typed_ir
|
||||
open Protocol.Environment.Error_monad
|
||||
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
|
||||
open Tezos_micheline.Micheline
|
||||
open Michelson_v1_primitives
|
||||
open Protocol.Environment
|
||||
|
||||
type ex_typed_value =
|
||||
Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
|
||||
|
||||
|
||||
let rec unparse_data_generic
|
||||
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
|
||||
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
||||
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
||||
mapper (Ex_typed_value (ty, a)) >>=? function
|
||||
| Some x -> return (x, ctxt)
|
||||
| None -> (
|
||||
match ty, a with
|
||||
| Unit_t _, () ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_Unit, [], []), ctxt)
|
||||
| Int_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| Nat_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| String_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
|
||||
return (String (-1, s), ctxt)
|
||||
| Bytes_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, s), ctxt)
|
||||
| Bool_t _, true ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_True, [], []), ctxt)
|
||||
| Bool_t _, false ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_False, [], []), ctxt)
|
||||
| Timestamp_t _, t ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Readable ->
|
||||
match Script_timestamp.to_notation t with
|
||||
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Some s -> return (String (-1, s), ctxt)
|
||||
end
|
||||
| Address_t _, c ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Contract_t _, (_, c) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Signature_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.to_b58check s), ctxt)
|
||||
end
|
||||
| Mutez_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
|
||||
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
|
||||
| Key_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
|
||||
end
|
||||
| Key_hash_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
||||
end
|
||||
| Operation_t _, op ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Alpha_context.Operation.internal_operation_encoding op in
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
||||
| Union_t ((tl, _), _, _), L l ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
||||
| Union_t (_, (tr, _), _), R r ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
||||
| Option_t ((t, _), _, _), Some v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t v >>=? fun (v, ctxt) ->
|
||||
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
||||
| Option_t _, None ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_None, [], []), ctxt)
|
||||
| List_t (t, _), items ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) element ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t element >>=? fun (unparsed, ctxt) ->
|
||||
return (unparsed :: l, ctxt))
|
||||
([], ctxt)
|
||||
items >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, List.rev items), ctxt)
|
||||
| Set_t (t, _), set ->
|
||||
let t = ty_of_comparable_ty t in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode t item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt)
|
||||
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Map_t (kt, vt, _), map ->
|
||||
let kt = ty_of_comparable_ty kt in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) (k, v) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||
unparse_data_generic ~mapper ctxt mode kt k >>=? fun (key, ctxt) ->
|
||||
unparse_data_generic ~mapper ctxt mode vt v >>=? fun (value, ctxt) ->
|
||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||
([], ctxt)
|
||||
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Big_map_t (_kt, _kv, _), _map ->
|
||||
return (Micheline.Seq (-1, []), ctxt)
|
||||
| Lambda_t _, Lam (_, original_code) ->
|
||||
unparse_code_generic ~mapper ctxt mode (root original_code)
|
||||
)
|
||||
|
||||
and unparse_code_generic ctxt ?mapper mode = function
|
||||
| Prim (loc, I_PUSH, [ ty ; data ], annot) ->
|
||||
Lwt.return (parse_ty ctxt ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t, ctxt) ->
|
||||
parse_data ctxt t data >>=? fun (data, ctxt) ->
|
||||
unparse_data_generic ?mapper ctxt mode t data >>=? fun (data, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)) >>=? fun ctxt ->
|
||||
return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt)
|
||||
| Seq (loc, items) ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))) >>=? fun ctxt ->
|
||||
return (Micheline.Seq (loc, List.rev items), ctxt)
|
||||
| Prim (loc, prim, items, annot) ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
unparse_code_generic ?mapper ctxt mode item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt) items >>=? fun (items, ctxt) ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)) >>=? fun ctxt ->
|
||||
return (Prim (loc, prim, List.rev items, annot), ctxt)
|
||||
| Int _ | String _ | Bytes _ as atom -> return (atom, ctxt)
|
||||
|
||||
module Interp_costs = Michelson_v1_gas.Cost_of
|
||||
type ex_descr_stack = Ex_descr_stack : (('a, 'b) descr * 'a stack) -> ex_descr_stack
|
||||
|
||||
let unparse_stack ctxt (stack, stack_ty) =
|
||||
(* We drop the gas limit as this function is only used for debugging/errors. *)
|
||||
let ctxt = Gas.set_unlimited ctxt in
|
||||
let rec unparse_stack
|
||||
: type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
|
||||
= function
|
||||
| Empty, Empty_t -> return_nil
|
||||
| Item (v, rest), Item_t (ty, rest_ty, annot) ->
|
||||
unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) ->
|
||||
unparse_stack (rest, rest_ty) >>=? fun rest ->
|
||||
let annot = match Script_ir_annot.unparse_var_annot annot with
|
||||
| [] -> None
|
||||
| [ a ] -> Some a
|
||||
| _ -> assert false in
|
||||
let data = Micheline.strip_locations data in
|
||||
return ((data, annot) :: rest) in
|
||||
unparse_stack (stack, stack_ty)
|
||||
|
||||
let rec step
|
||||
: type b a.
|
||||
(?log: execution_trace ref ->
|
||||
context ->
|
||||
source: Contract.t ->
|
||||
self: Contract.t ->
|
||||
payer: Contract.t ->
|
||||
?visitor: (ex_descr_stack -> unit) ->
|
||||
Tez.t ->
|
||||
(b, a) descr -> b stack ->
|
||||
(a stack * context) tzresult Lwt.t) =
|
||||
fun ?log ctxt ~source ~self ~payer ?visitor amount ({ instr ; loc ; _ } as descr) stack ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.cycle) >>=? fun ctxt ->
|
||||
(match visitor with
|
||||
| Some visitor -> visitor @@ Ex_descr_stack(descr, stack)
|
||||
| None -> ()) ;
|
||||
let step_same ctxt = step ?log ctxt ~source ~self ~payer ?visitor amount in
|
||||
let logged_return : type a b.
|
||||
(b, a) descr ->
|
||||
a stack * context ->
|
||||
(a stack * context) tzresult Lwt.t =
|
||||
fun descr (ret, ctxt) ->
|
||||
match log with
|
||||
| None -> return (ret, ctxt)
|
||||
| Some log ->
|
||||
trace
|
||||
Cannot_serialize_log
|
||||
(unparse_stack ctxt (ret, descr.aft)) >>=? fun stack ->
|
||||
log := (descr.loc, Gas.level ctxt, stack) :: !log ;
|
||||
return (ret, ctxt) in
|
||||
let get_log (log : execution_trace ref option) =
|
||||
Option.map ~f:(fun l -> List.rev !l) log in
|
||||
let consume_gas_terop : type ret arg1 arg2 arg3 rest.
|
||||
(_ * (_ * (_ * rest)), ret * rest) descr ->
|
||||
((arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3) ->
|
||||
(arg1 -> arg2 -> arg3 -> Gas.cost) ->
|
||||
rest stack ->
|
||||
((ret * rest) stack * context) tzresult Lwt.t =
|
||||
fun descr (op, x1, x2, x3) cost_func rest ->
|
||||
Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3)) >>=? fun ctxt ->
|
||||
logged_return descr (Item (op x1 x2 x3, rest), ctxt) in
|
||||
let consume_gas_binop : type ret arg1 arg2 rest.
|
||||
(_ * (_ * rest), ret * rest) descr ->
|
||||
((arg1 -> arg2 -> ret) * arg1 * arg2) ->
|
||||
(arg1 -> arg2 -> Gas.cost) ->
|
||||
rest stack ->
|
||||
context ->
|
||||
((ret * rest) stack * context) tzresult Lwt.t =
|
||||
fun descr (op, x1, x2) cost_func rest ctxt ->
|
||||
Lwt.return (Gas.consume ctxt (cost_func x1 x2)) >>=? fun ctxt ->
|
||||
logged_return descr (Item (op x1 x2, rest), ctxt) in
|
||||
let consume_gas_unop : type ret arg rest.
|
||||
(_ * rest, ret * rest) descr ->
|
||||
((arg -> ret) * arg) ->
|
||||
(arg -> Gas.cost) ->
|
||||
rest stack ->
|
||||
context ->
|
||||
((ret * rest) stack * context) tzresult Lwt.t =
|
||||
fun descr (op, arg) cost_func rest ctxt ->
|
||||
Lwt.return (Gas.consume ctxt (cost_func arg)) >>=? fun ctxt ->
|
||||
logged_return descr (Item (op arg, rest), ctxt) in
|
||||
let consume_gaz_comparison :
|
||||
type t rest.
|
||||
(t * (t * rest), Script_int.z Script_int.num * rest) descr ->
|
||||
(t -> t -> int) ->
|
||||
(t -> t -> Gas.cost) ->
|
||||
t -> t ->
|
||||
rest stack ->
|
||||
((Script_int.z Script_int.num * rest) stack * context) tzresult Lwt.t =
|
||||
fun descr op cost x1 x2 rest ->
|
||||
Lwt.return (Gas.consume ctxt (cost x1 x2)) >>=? fun ctxt ->
|
||||
logged_return descr (Item (Script_int.of_int @@ op x1 x2, rest), ctxt) in
|
||||
let logged_return :
|
||||
a stack * context ->
|
||||
(a stack * context) tzresult Lwt.t =
|
||||
logged_return descr in
|
||||
match instr, stack with
|
||||
(* stack ops *)
|
||||
| Drop, Item (_, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
||||
logged_return (rest, ctxt)
|
||||
| Dup, Item (v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
||||
logged_return (Item (v, Item (v, rest)), ctxt)
|
||||
| Swap, Item (vi, Item (vo, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
||||
logged_return (Item (vo, Item (vi, rest)), ctxt)
|
||||
| Const v, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
||||
logged_return (Item (v, rest), ctxt)
|
||||
(* options *)
|
||||
| Cons_some, Item (v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
|
||||
logged_return (Item (Some v, rest), ctxt)
|
||||
| Cons_none _, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt ->
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
| If_none (bt, _), Item (None, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bt rest
|
||||
| If_none (_, bf), Item (Some v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bf (Item (v, rest))
|
||||
(* pairs *)
|
||||
| Cons_pair, Item (a, Item (b, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.pair) >>=? fun ctxt ->
|
||||
logged_return (Item ((a, b), rest), ctxt)
|
||||
| Car, Item ((a, _), rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
|
||||
logged_return (Item (a, rest), ctxt)
|
||||
| Cdr, Item ((_, b), rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.pair_access) >>=? fun ctxt ->
|
||||
logged_return (Item (b, rest), ctxt)
|
||||
(* unions *)
|
||||
| Left, Item (v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
|
||||
logged_return (Item (L v, rest), ctxt)
|
||||
| Right, Item (v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.wrap) >>=? fun ctxt ->
|
||||
logged_return (Item (R v, rest), ctxt)
|
||||
| If_left (bt, _), Item (L v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bt (Item (v, rest))
|
||||
| If_left (_, bf), Item (R v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bf (Item (v, rest))
|
||||
(* lists *)
|
||||
| Cons_list, Item (hd, Item (tl, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.cons) >>=? fun ctxt ->
|
||||
logged_return (Item (hd :: tl, rest), ctxt)
|
||||
| Nil, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data) >>=? fun ctxt ->
|
||||
logged_return (Item ([], rest), ctxt)
|
||||
| If_cons (_, bf), Item ([], rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bf rest
|
||||
| If_cons (bt, _), Item (hd :: tl, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bt (Item (hd, Item (tl, rest)))
|
||||
| List_map body, Item (l, rest) ->
|
||||
let rec loop rest ctxt l acc =
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
match l with
|
||||
| [] -> return (Item (List.rev acc, rest), ctxt)
|
||||
| hd :: tl ->
|
||||
step_same ctxt body (Item (hd, rest))
|
||||
>>=? fun (Item (hd, rest), ctxt) ->
|
||||
loop rest ctxt tl (hd :: acc)
|
||||
in loop rest ctxt l [] >>=? fun (res, ctxt) ->
|
||||
logged_return (res, ctxt)
|
||||
| List_size, Item (list, rest) ->
|
||||
Lwt.return
|
||||
(List.fold_left
|
||||
(fun acc _ ->
|
||||
acc >>? fun (size, ctxt) ->
|
||||
Gas.consume ctxt Interp_costs.list_size >>? fun ctxt ->
|
||||
ok (size + 1 (* FIXME: overflow *), ctxt))
|
||||
(ok (0, ctxt)) list) >>=? fun (len, ctxt) ->
|
||||
logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
|
||||
| List_iter body, Item (l, init) ->
|
||||
let rec loop ctxt l stack =
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
match l with
|
||||
| [] -> return (stack, ctxt)
|
||||
| hd :: tl ->
|
||||
step_same ctxt body (Item (hd, stack))
|
||||
>>=? fun (stack, ctxt) ->
|
||||
loop ctxt tl stack
|
||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||
logged_return (res, ctxt)
|
||||
(* sets *)
|
||||
| Empty_set t, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.empty_set) >>=? fun ctxt ->
|
||||
logged_return (Item (empty_set t, rest), ctxt)
|
||||
| Set_iter body, Item (set, init) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set)) >>=? fun ctxt ->
|
||||
let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
|
||||
let rec loop ctxt l stack =
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
match l with
|
||||
| [] -> return (stack, ctxt)
|
||||
| hd :: tl ->
|
||||
step_same ctxt body (Item (hd, stack))
|
||||
>>=? fun (stack, ctxt) ->
|
||||
loop ctxt tl stack
|
||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||
logged_return (res, ctxt)
|
||||
| Set_mem, Item (v, Item (set, rest)) ->
|
||||
consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
|
||||
| Set_update, Item (v, Item (presence, Item (set, rest))) ->
|
||||
consume_gas_terop descr (set_update, v, presence, set) Interp_costs.set_update rest
|
||||
| Set_size, Item (set, rest) ->
|
||||
consume_gas_unop descr (set_size, set) (fun _ -> Interp_costs.set_size) rest ctxt
|
||||
(* maps *)
|
||||
| Empty_map (t, _), rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.empty_map) >>=? fun ctxt ->
|
||||
logged_return (Item (empty_map t, rest), ctxt)
|
||||
| Map_map body, Item (map, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
||||
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
||||
let rec loop rest ctxt l acc =
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
match l with
|
||||
| [] -> return (acc, ctxt)
|
||||
| (k, _) as hd :: tl ->
|
||||
step_same ctxt body (Item (hd, rest))
|
||||
>>=? fun (Item (hd, rest), ctxt) ->
|
||||
loop rest ctxt tl (map_update k (Some hd) acc)
|
||||
in loop rest ctxt l (empty_map (map_key_ty map)) >>=? fun (res, ctxt) ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Map_iter body, Item (map, init) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map)) >>=? fun ctxt ->
|
||||
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
|
||||
let rec loop ctxt l stack =
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
match l with
|
||||
| [] -> return (stack, ctxt)
|
||||
| hd :: tl ->
|
||||
step_same ctxt body (Item (hd, stack))
|
||||
>>=? fun (stack, ctxt) ->
|
||||
loop ctxt tl stack
|
||||
in loop ctxt l init >>=? fun (res, ctxt) ->
|
||||
logged_return (res, ctxt)
|
||||
| Map_mem, Item (v, Item (map, rest)) ->
|
||||
consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
|
||||
| Map_get, Item (v, Item (map, rest)) ->
|
||||
consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
|
||||
| Map_update, Item (k, Item (v, Item (map, rest))) ->
|
||||
consume_gas_terop descr (map_update, k, v, map) Interp_costs.map_update rest
|
||||
| Map_size, Item (map, rest) ->
|
||||
consume_gas_unop descr (map_size, map) (fun _ -> Interp_costs.map_size) rest ctxt
|
||||
(* Big map operations *)
|
||||
| Big_map_mem, Item (key, Item (map, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_mem key map)) >>=? fun ctxt ->
|
||||
Script_ir_translator.big_map_mem ctxt self key map >>=? fun (res, ctxt) ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Big_map_get, Item (key, Item (map, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.big_map_get key map)) >>=? fun ctxt ->
|
||||
Script_ir_translator.big_map_get ctxt self key map >>=? fun (res, ctxt) ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Big_map_update, Item (key, Item (maybe_value, Item (map, rest))) ->
|
||||
consume_gas_terop descr
|
||||
(Script_ir_translator.big_map_update, key, maybe_value, map)
|
||||
Interp_costs.big_map_update rest
|
||||
(* timestamp operations *)
|
||||
| Add_seconds_to_timestamp, Item (n, Item (t, rest)) ->
|
||||
consume_gas_binop descr
|
||||
(Script_timestamp.add_delta, t, n)
|
||||
Interp_costs.add_timestamp rest ctxt
|
||||
| Add_timestamp_to_seconds, Item (t, Item (n, rest)) ->
|
||||
consume_gas_binop descr (Script_timestamp.add_delta, t, n)
|
||||
Interp_costs.add_timestamp rest ctxt
|
||||
| Sub_timestamp_seconds, Item (t, Item (s, rest)) ->
|
||||
consume_gas_binop descr (Script_timestamp.sub_delta, t, s)
|
||||
Interp_costs.sub_timestamp rest ctxt
|
||||
| Diff_timestamps, Item (t1, Item (t2, rest)) ->
|
||||
consume_gas_binop descr (Script_timestamp.diff, t1, t2)
|
||||
Interp_costs.diff_timestamps rest ctxt
|
||||
(* string operations *)
|
||||
| Concat_string_pair, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y])) >>=? fun ctxt ->
|
||||
let s = String.concat "" [x; y] in
|
||||
logged_return (Item (s, rest), ctxt)
|
||||
| Concat_string, Item (ss, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt ->
|
||||
let s = String.concat "" ss in
|
||||
logged_return (Item (s, rest), ctxt)
|
||||
| Slice_string, Item (offset, Item (length, Item (s, rest))) ->
|
||||
let s_length = Z.of_int (String.length s) in
|
||||
let offset = Script_int.to_zint offset in
|
||||
let length = Script_int.to_zint length in
|
||||
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
|
||||
logged_return (Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
|
||||
else
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
| String_size, Item (s, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
||||
logged_return (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
|
||||
(* bytes operations *)
|
||||
| Concat_bytes_pair, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y])) >>=? fun ctxt ->
|
||||
let s = MBytes.concat "" [x; y] in
|
||||
logged_return (Item (s, rest), ctxt)
|
||||
| Concat_bytes, Item (ss, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss)) >>=? fun ctxt ->
|
||||
let s = MBytes.concat "" ss in
|
||||
logged_return (Item (s, rest), ctxt)
|
||||
| Slice_bytes, Item (offset, Item (length, Item (s, rest))) ->
|
||||
let s_length = Z.of_int (MBytes.length s) in
|
||||
let offset = Script_int.to_zint offset in
|
||||
let length = Script_int.to_zint length in
|
||||
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))) >>=? fun ctxt ->
|
||||
logged_return (Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest), ctxt)
|
||||
else
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0)) >>=? fun ctxt ->
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
| Bytes_size, Item (s, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
||||
logged_return (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
|
||||
(* currency operations *)
|
||||
| Add_tez, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
|
||||
Lwt.return Tez.(x +? y) >>=? fun res ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Sub_tez, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
|
||||
Lwt.return Tez.(x -? y) >>=? fun res ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Mul_teznat, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
|
||||
begin
|
||||
match Script_int.to_int64 y with
|
||||
| None -> fail (Overflow (loc, get_log log))
|
||||
| Some y ->
|
||||
Lwt.return Tez.(x *? y) >>=? fun res ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
end
|
||||
| Mul_nattez, Item (y, Item (x, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64) >>=? fun ctxt ->
|
||||
begin
|
||||
match Script_int.to_int64 y with
|
||||
| None -> fail (Overflow (loc, get_log log))
|
||||
| Some y ->
|
||||
Lwt.return Tez.(x *? y) >>=? fun res ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
end
|
||||
(* boolean operations *)
|
||||
| Or, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr ((||), x, y) Interp_costs.bool_binop rest ctxt
|
||||
| And, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr ((&&), x, y) Interp_costs.bool_binop rest ctxt
|
||||
| Xor, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Compare.Bool.(<>), x, y) Interp_costs.bool_binop rest ctxt
|
||||
| Not, Item (x, rest) ->
|
||||
consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
|
||||
(* integer operations *)
|
||||
| Is_nat, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
|
||||
| Abs_int, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
|
||||
| Int_nat, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
|
||||
| Neg_int, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
|
||||
| Neg_nat, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
|
||||
| Add_intint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
|
||||
| Add_intnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
|
||||
| Add_natint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
|
||||
| Add_natnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest ctxt
|
||||
| Sub_int, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
|
||||
| Mul_intint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
|
||||
| Mul_intnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
|
||||
| Mul_natint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
|
||||
| Mul_natnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest ctxt
|
||||
| Ediv_teznat, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
|
||||
let x = Script_int.of_int64 (Tez.to_mutez x) in
|
||||
consume_gas_binop descr
|
||||
((fun x y ->
|
||||
match Script_int.ediv x y with
|
||||
| None -> None
|
||||
| Some (q, r) ->
|
||||
match Script_int.to_int64 q,
|
||||
Script_int.to_int64 r with
|
||||
| Some q, Some r ->
|
||||
begin
|
||||
match Tez.of_mutez q, Tez.of_mutez r with
|
||||
| Some q, Some r -> Some (q,r)
|
||||
(* Cannot overflow *)
|
||||
| _ -> assert false
|
||||
end
|
||||
(* Cannot overflow *)
|
||||
| _ -> assert false),
|
||||
x, y)
|
||||
Interp_costs.div
|
||||
rest
|
||||
ctxt
|
||||
| Ediv_tez, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z) >>=? fun ctxt ->
|
||||
let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
|
||||
let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
|
||||
consume_gas_binop descr
|
||||
((fun x y -> match Script_int.ediv_n x y with
|
||||
| None -> None
|
||||
| Some (q, r) ->
|
||||
match Script_int.to_int64 r with
|
||||
| None -> assert false (* Cannot overflow *)
|
||||
| Some r ->
|
||||
match Tez.of_mutez r with
|
||||
| None -> assert false (* Cannot overflow *)
|
||||
| Some r -> Some (q, r)),
|
||||
x, y)
|
||||
Interp_costs.div
|
||||
rest
|
||||
ctxt
|
||||
| Ediv_intint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
|
||||
| Ediv_intnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
|
||||
| Ediv_natint, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest ctxt
|
||||
| Ediv_natnat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div rest ctxt
|
||||
| Lsl_nat, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y)) >>=? fun ctxt ->
|
||||
begin
|
||||
match Script_int.shift_left_n x y with
|
||||
| None -> fail (Overflow (loc, get_log log))
|
||||
| Some x -> logged_return (Item (x, rest), ctxt)
|
||||
end
|
||||
| Lsr_nat, Item (x, Item (y, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y)) >>=? fun ctxt ->
|
||||
begin
|
||||
match Script_int.shift_right_n x y with
|
||||
| None -> fail (Overflow (loc, get_log log))
|
||||
| Some r -> logged_return (Item (r, rest), ctxt)
|
||||
end
|
||||
| Or_nat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor rest ctxt
|
||||
| And_nat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt
|
||||
| And_int_nat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand rest ctxt
|
||||
| Xor_nat, Item (x, Item (y, rest)) ->
|
||||
consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor rest ctxt
|
||||
| Not_int, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
|
||||
| Not_nat, Item (x, rest) ->
|
||||
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest ctxt
|
||||
(* control *)
|
||||
| Seq (hd, tl), stack ->
|
||||
step_same ctxt hd stack >>=? fun (trans, ctxt) ->
|
||||
step_same ctxt tl trans
|
||||
| If (bt, _), Item (true, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bt rest
|
||||
| If (_, bf), Item (false, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.branch) >>=? fun ctxt ->
|
||||
step_same ctxt bf rest
|
||||
| Loop body, Item (true, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
step_same ctxt body rest >>=? fun (trans, ctxt) ->
|
||||
step_same ctxt descr trans
|
||||
| Loop _, Item (false, rest) ->
|
||||
logged_return (rest, ctxt)
|
||||
| Loop_left body, Item (L v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
step_same ctxt body (Item (v, rest)) >>=? fun (trans, ctxt) ->
|
||||
step_same ctxt descr trans
|
||||
| Loop_left _, Item (R v, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle) >>=? fun ctxt ->
|
||||
logged_return (Item (v, rest), ctxt)
|
||||
| Dip b, Item (ign, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.stack_op) >>=? fun ctxt ->
|
||||
step_same ctxt b rest >>=? fun (res, ctxt) ->
|
||||
logged_return (Item (ign, res), ctxt)
|
||||
| Exec, Item (arg, Item (lam, rest)) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.exec) >>=? fun ctxt ->
|
||||
interp ?log ctxt ~source ~payer ~self amount lam arg >>=? fun (res, ctxt) ->
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Lambda lam, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.push) >>=? fun ctxt ->
|
||||
logged_return (Item (lam, rest), ctxt)
|
||||
| Failwith tv, Item (v, _) ->
|
||||
trace Cannot_serialize_failure
|
||||
(unparse_data ctxt Optimized tv v) >>=? fun (v, _ctxt) ->
|
||||
let v = Micheline.strip_locations v in
|
||||
fail (Reject (loc, v, get_log log))
|
||||
| Nop, stack ->
|
||||
logged_return (stack, ctxt)
|
||||
(* comparison *)
|
||||
| Compare (Bool_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Compare.Bool.compare Interp_costs.compare_bool a b rest
|
||||
| Compare (String_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Compare.String.compare Interp_costs.compare_string a b rest
|
||||
| Compare (Bytes_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr MBytes.compare Interp_costs.compare_bytes a b rest
|
||||
| Compare (Mutez_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Tez.compare Interp_costs.compare_tez a b rest
|
||||
| Compare (Int_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Script_int.compare Interp_costs.compare_int a b rest
|
||||
| Compare (Nat_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Script_int.compare Interp_costs.compare_nat a b rest
|
||||
| Compare (Key_hash_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Signature.Public_key_hash.compare
|
||||
Interp_costs.compare_key_hash a b rest
|
||||
| Compare (Timestamp_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Script_timestamp.compare Interp_costs.compare_timestamp a b rest
|
||||
| Compare (Address_key _), Item (a, Item (b, rest)) ->
|
||||
consume_gaz_comparison descr Contract.compare Interp_costs.compare_address a b rest
|
||||
(* comparators *)
|
||||
| Eq, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres = 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
| Neq, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres <> 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
| Lt, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres < 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
| Le, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres <= 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
| Gt, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres > 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
| Ge, Item (cmpres, rest) ->
|
||||
let cmpres = Script_int.compare cmpres Script_int.zero in
|
||||
let cmpres = Compare.Int.(cmpres >= 0) in
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.compare_res) >>=? fun ctxt ->
|
||||
logged_return (Item (cmpres, rest), ctxt)
|
||||
(* packing *)
|
||||
| Pack t, Item (value, rest) ->
|
||||
Script_ir_translator.pack_data ctxt t value >>=? fun (bytes, ctxt) ->
|
||||
logged_return (Item (bytes, rest), ctxt)
|
||||
| Unpack t, Item (bytes, rest) ->
|
||||
Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes)) >>=? fun () ->
|
||||
if Compare.Int.(MBytes.length bytes >= 1) &&
|
||||
Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then
|
||||
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
|
||||
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
|
||||
| None ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
| Some expr ->
|
||||
Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr)) >>=? fun ctxt ->
|
||||
parse_data ctxt t (Micheline.root expr) >>= function
|
||||
| Ok (value, ctxt) ->
|
||||
logged_return (Item (Some value, rest), ctxt)
|
||||
| Error _ignored ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes)) >>=? fun ctxt ->
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
else
|
||||
logged_return (Item (None, rest), ctxt)
|
||||
(* protocol *)
|
||||
| Address, Item ((_, contract), rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.address) >>=? fun ctxt ->
|
||||
logged_return (Item (contract, rest), ctxt)
|
||||
| Contract t, Item (contract, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.contract) >>=? fun ctxt ->
|
||||
Script_ir_translator.parse_contract_for_script ctxt loc t contract >>=? fun (ctxt, maybe_contract) ->
|
||||
logged_return (Item (maybe_contract, rest), ctxt)
|
||||
| Transfer_tokens,
|
||||
Item (p, Item (amount, Item ((tp, destination), rest))) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.transfer) >>=? fun ctxt ->
|
||||
unparse_data ctxt Optimized tp p >>=? fun (p, ctxt) ->
|
||||
let operation =
|
||||
Transaction
|
||||
{ amount ; destination ;
|
||||
parameters = Some (Script.lazy_expr (Micheline.strip_locations p)) } in
|
||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
|
||||
| Create_account,
|
||||
Item (manager, Item (delegate, Item (delegatable, Item (credit, rest)))) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
||||
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
||||
let operation =
|
||||
Origination
|
||||
{ credit ; manager ; delegate ; preorigination = Some contract ;
|
||||
delegatable ; script = None ; spendable = true } in
|
||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce },
|
||||
Item (contract, rest)), ctxt)
|
||||
| Implicit_account, Item (key, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->
|
||||
let contract = Contract.implicit_contract key in
|
||||
logged_return (Item ((Unit_t None, contract), rest), ctxt)
|
||||
| Create_contract (storage_type, param_type, Lam (_, code)),
|
||||
Item (manager, Item
|
||||
(delegate, Item
|
||||
(spendable, Item
|
||||
(delegatable, Item
|
||||
(credit, Item
|
||||
(init, rest)))))) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt ->
|
||||
unparse_ty ctxt param_type >>=? fun (unparsed_param_type, ctxt) ->
|
||||
unparse_ty ctxt storage_type >>=? fun (unparsed_storage_type, ctxt) ->
|
||||
let code =
|
||||
Micheline.strip_locations
|
||||
(Seq (0, [ Prim (0, K_parameter, [ unparsed_param_type ], []) ;
|
||||
Prim (0, K_storage, [ unparsed_storage_type ], []) ;
|
||||
Prim (0, K_code, [ Micheline.root code ], []) ])) in
|
||||
unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) ->
|
||||
let storage = Micheline.strip_locations storage in
|
||||
Contract.fresh_contract_from_current_nonce ctxt >>=? fun (ctxt, contract) ->
|
||||
let operation =
|
||||
Origination
|
||||
{ credit ; manager ; delegate ; preorigination = Some contract ;
|
||||
delegatable ; spendable ;
|
||||
script = Some { code = Script.lazy_expr code ;
|
||||
storage = Script.lazy_expr storage } } in
|
||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||
logged_return
|
||||
(Item (Internal_operation { source = self ; operation ; nonce },
|
||||
Item (contract, rest)), ctxt)
|
||||
| Set_delegate,
|
||||
Item (delegate, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.create_account) >>=? fun ctxt ->
|
||||
let operation = Delegation delegate in
|
||||
Lwt.return (fresh_internal_nonce ctxt) >>=? fun (ctxt, nonce) ->
|
||||
logged_return (Item (Internal_operation { source = self ; operation ; nonce }, rest), ctxt)
|
||||
| Balance, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.balance) >>=? fun ctxt ->
|
||||
Contract.get_balance ctxt self >>=? fun balance ->
|
||||
logged_return (Item (balance, rest), ctxt)
|
||||
| Now, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.now) >>=? fun ctxt ->
|
||||
let now = Script_timestamp.now ctxt in
|
||||
logged_return (Item (now, rest), ctxt)
|
||||
| Check_signature, Item (key, Item (signature, Item (message, rest))) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.check_signature) >>=? fun ctxt ->
|
||||
let res = Signature.check key signature message in
|
||||
logged_return (Item (res, rest), ctxt)
|
||||
| Hash_key, Item (key, rest) ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.hash_key) >>=? fun ctxt ->
|
||||
logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
|
||||
| Blake2b, Item (bytes, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
|
||||
let hash = Raw_hashes.blake2b bytes in
|
||||
logged_return (Item (hash, rest), ctxt)
|
||||
| Sha256, Item (bytes, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 32)) >>=? fun ctxt ->
|
||||
let hash = Raw_hashes.sha256 bytes in
|
||||
logged_return (Item (hash, rest), ctxt)
|
||||
| Sha512, Item (bytes, rest) ->
|
||||
Lwt.return (Gas.consume ctxt (Interp_costs.hash bytes 64)) >>=? fun ctxt ->
|
||||
let hash = Raw_hashes.sha512 bytes in
|
||||
logged_return (Item (hash, rest), ctxt)
|
||||
| Steps_to_quota, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota) >>=? fun ctxt ->
|
||||
let steps = match Gas.level ctxt with
|
||||
| Limited { remaining } -> remaining
|
||||
| Unaccounted -> Z.of_string "99999999" in
|
||||
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
|
||||
| Source, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
||||
logged_return (Item (payer, rest), ctxt)
|
||||
| Sender, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
|
||||
logged_return (Item (source, rest), ctxt)
|
||||
| Self t, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.self) >>=? fun ctxt ->
|
||||
logged_return (Item ((t,self), rest), ctxt)
|
||||
| Amount, rest ->
|
||||
Lwt.return (Gas.consume ctxt Interp_costs.amount) >>=? fun ctxt ->
|
||||
logged_return (Item (amount, rest), ctxt)
|
||||
|
||||
and interp
|
||||
: type p r.
|
||||
(?log: execution_trace ref ->
|
||||
context ->
|
||||
source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t ->
|
||||
(p, r) lambda -> p ->
|
||||
(r * context) tzresult Lwt.t)
|
||||
= fun ?log ctxt ~source ~payer ~self amount (Lam (code, _)) arg ->
|
||||
let stack = (Item (arg, Empty)) in
|
||||
begin match log with
|
||||
| None -> return_unit
|
||||
| Some log ->
|
||||
trace Cannot_serialize_log
|
||||
(unparse_stack ctxt (stack, code.bef)) >>=? fun stack ->
|
||||
log := (code.loc, Gas.level ctxt, stack) :: !log ;
|
||||
return_unit
|
||||
end >>=? fun () ->
|
||||
step ctxt ~source ~payer ~self amount code stack >>=? fun (Item (ret, Empty), ctxt) ->
|
||||
return (ret, ctxt)
|
||||
|
||||
|
||||
|
||||
end
|
||||
|
||||
open X_error_monad
|
||||
|
||||
let stack_ty_eq (type a b)
|
||||
?(tezos_context = dummy_environment.tezos_context)
|
||||
(a:a stack_ty) (b:b stack_ty) =
|
||||
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) ->
|
||||
alpha_wrap (X.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) ->
|
||||
ok Eq
|
||||
|
||||
let ty_eq (type a b)
|
||||
@ -37,7 +962,7 @@ let parse_michelson (type aft)
|
||||
match j with
|
||||
| Typed descr -> (
|
||||
Lwt.return (
|
||||
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
|
||||
alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
|
||||
let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in
|
||||
Ok descr
|
||||
)
|
||||
@ -59,7 +984,7 @@ let parse_michelson_fail (type aft)
|
||||
match j with
|
||||
| Typed descr -> (
|
||||
Lwt.return (
|
||||
alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
|
||||
alpha_wrap (X.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) ->
|
||||
let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in
|
||||
Ok descr
|
||||
)
|
||||
@ -87,7 +1012,7 @@ let parse_michelson_ty
|
||||
let unparse_michelson_data
|
||||
?(tezos_context = dummy_environment.tezos_context)
|
||||
?mapper ty value : Michelson.t tzresult Lwt.t =
|
||||
Script_ir_translator.unparse_data tezos_context ?mapper
|
||||
X.unparse_data_generic tezos_context ?mapper
|
||||
Readable ty value >>=?? fun (michelson, _) ->
|
||||
return michelson
|
||||
|
||||
@ -129,5 +1054,5 @@ let interpret ?(options = default_options) ?visitor (instr:('a, 'b) descr) (bef:
|
||||
payer ;
|
||||
amount ;
|
||||
} = options in
|
||||
Script_interpreter.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=??
|
||||
X.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=??
|
||||
fun (stack, _) -> return stack
|
||||
|
||||
5
vendors/ligo-utils/simple-utils/dune
vendored
5
vendors/ligo-utils/simple-utils/dune
vendored
@ -1,11 +1,12 @@
|
||||
(library
|
||||
(name simple_utils)
|
||||
(public_name simple-utils)
|
||||
(preprocess
|
||||
(pps simple-utils.ppx_let_generalized))
|
||||
(libraries
|
||||
yojson
|
||||
unix
|
||||
str
|
||||
)
|
||||
(preprocess
|
||||
(pps ppx_let)
|
||||
)
|
||||
)
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user