diff --git a/.gitignore b/.gitignore index 9d8d63c32539b6d1a44c1f03c747f7fddc0c4ea5..d59b750b42d54fb179884e0602e059a9c9d2c316 100644 --- a/.gitignore +++ b/.gitignore @@ -6,10 +6,13 @@ *.aux *.glob *.vo -*.lia.cache +*.vok +*.vos +*.cache # Generated by configure and coq_makefile _CoqProject Makefile +.Makefile.d .coqdeps.d # OCaml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b5bbdd4fc3829a01d44ab2f4a5ae17df1b3beb4b..f86ecbe905acb751540ca5959d587cfb92133964 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,12 +10,14 @@ stages: - sudo apt-get update -y -q script: - sudo chown -R coq:coq "$CI_PROJECT_DIR" - - DEBIAN_FRONTEND=noninteractive sudo apt-get install -y -q xz-utils wget emacs libgmp-dev + - DEBIAN_FRONTEND=noninteractive sudo apt-get install -y -q xz-utils wget emacs - export scversion="latest" - wget -qO- "https://github.com/koalaman/shellcheck/releases/download/latest/shellcheck-"${scversion}".linux.x86_64.tar.xz" | tar -xJv - shellcheck-"${scversion}"/shellcheck `find -name 'configure'` - emacs --batch -l scripts/org-lint-README.el --kill - - opam pin add -k git -y -j ${NJOBS} coq-mi-cho-coq . + - opam pin add -k git -y --no-action coq-mi-cho-coq . + - opam depext -y coq-mi-cho-coq + - opam install -y -j ${NJOBS} --with-test coq-mi-cho-coq - which michocoq coq:8.8: @@ -26,3 +28,6 @@ coq:8.9: coq:8.10: extends: .build + +coq:8.11: + extends: .build diff --git a/Makefile.local b/Makefile.local new file mode 100644 index 0000000000000000000000000000000000000000..5db71ffdd9aa7aa65842f88c278f0de83e24ca62 --- /dev/null +++ b/Makefile.local @@ -0,0 +1,21 @@ + +## Tests + +MICHOCOQ=src/michocoq/extraction/michocoq.native + +RESET_REGRESSION=false + +TESTS=$(wildcard src/contracts/testsuite/*/*.tz) + +TESTS_RESULTS=$(TESTS:.tz=.tz.res) + +%.tz.res: %.tz + $(MICHOCOQ) "$$(cat $<)" > $*.tz.res +ifeq ($(RESET_REGRESSION),true) + @cp $*.tz.res $*.tz.expected +else + @diff $*.tz.res $*.tz.expected +endif + +test: all $(TESTS_RESULTS) + @rm $(TESTS_RESULTS) diff --git a/coq-mi-cho-coq.opam b/coq-mi-cho-coq.opam index 265b4ee33767ac74a139eddbc952ef7192819f3d..c59ec25493d4a1eeed068efcaa962aa9ce62a446 100644 --- a/coq-mi-cho-coq.opam +++ b/coq-mi-cho-coq.opam @@ -18,19 +18,18 @@ install: [ make "install" ] depends: [ - "ocamlbuild" + "coq-list-string" "coq-menhirlib" {>= "20190626"} + "coq-moment" {>= "1.2.0"} "coq-ott" {>= "0.29"} "coq" {>= "8.8"} - "coq-ott" - "ott" "menhir" - "coq-menhirlib" {>= "20190626"} - "zarith" "ocaml" {>= "4.07.1"} + "ocamlbuild" "ott" {build & >= "0.29"} "zarith" ] +build-test: [ make "test" ] description: """ Michelson is a language for writing smart contracts on the Tezos blockchain. diff --git a/src/contracts/arthur/return_to_sender.tz b/src/contracts/arthur/return_to_sender.tz deleted file mode 100644 index 5054e90aaf10517df892d88a38b7cd86283a68e8..0000000000000000000000000000000000000000 --- a/src/contracts/arthur/return_to_sender.tz +++ /dev/null @@ -1,27 +0,0 @@ -# (She wrote upon it) - -parameter unit; - -storage unit; - -code { - CDR ; - NIL operation ; - AMOUNT; - PUSH mutez 0; - IFCMPEQ - # Typical scenario, no operation needed - { - } - # Return funds if sent by mistake - { - SOURCE ; - CONTRACT unit ; - ASSERT_SOME ; - AMOUNT ; - UNIT ; - TRANSFER_TOKENS ; - CONS ; - }; - PAIR; - } diff --git a/src/contracts/testsuite/attic/accounts.tz.expected b/src/contracts/testsuite/attic/accounts.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/accounts.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/add1.tz.expected b/src/contracts/testsuite/attic/add1.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/add1.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/add1_list.tz.expected b/src/contracts/testsuite/attic/add1_list.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/add1_list.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/after_strategy.tz.expected b/src/contracts/testsuite/attic/after_strategy.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/after_strategy.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/always.tz.expected b/src/contracts/testsuite/attic/always.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/always.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/append.tz.expected b/src/contracts/testsuite/attic/append.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/append.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/at_least.tz.expected b/src/contracts/testsuite/attic/at_least.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/at_least.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/auction.tz.expected b/src/contracts/testsuite/attic/auction.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/auction.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/bad_lockup.tz b/src/contracts/testsuite/attic/bad_lockup.tz index aeb3ec7fea8efa6db127203ecf37a92fefad0043..f334e899e71cfe2d8cda8bcc2ef3295384fddb78 100644 --- a/src/contracts/testsuite/attic/bad_lockup.tz +++ b/src/contracts/testsuite/attic/bad_lockup.tz @@ -1,6 +1,6 @@ parameter unit; -storage (pair timestamp (pair (contract unit) (contract unit))); +storage (pair timestamp (pair address address)); code { CDR; DUP; CAR; NOW; CMPLT; IF {FAIL} {}; - DUP; CDAR; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; SWAP; - DUP; CDDR; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; DIP {SWAP} ; + DUP; CDAR; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; SWAP; + DUP; CDDR; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 100000000; UNIT; TRANSFER_TOKENS; DIP {SWAP} ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } diff --git a/src/contracts/testsuite/attic/bad_lockup.tz.expected b/src/contracts/testsuite/attic/bad_lockup.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/bad_lockup.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/big_map_union.tz.expected b/src/contracts/testsuite/attic/big_map_union.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/big_map_union.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/cadr_annotation.tz.expected b/src/contracts/testsuite/attic/cadr_annotation.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/cadr_annotation.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/concat.tz.expected b/src/contracts/testsuite/attic/concat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/concat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/conditionals.tz.expected b/src/contracts/testsuite/attic/conditionals.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/conditionals.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/cons_twice.tz.expected b/src/contracts/testsuite/attic/cons_twice.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/cons_twice.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/cps_fact.tz.expected b/src/contracts/testsuite/attic/cps_fact.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/cps_fact.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/create_add1_lists.tz b/src/contracts/testsuite/attic/create_add1_lists.tz index c183ad1e26ea6425032db083e5a64925c7421c81..5a4245966379e4ae96d793947dbec877ab9165a3 100644 --- a/src/contracts/testsuite/attic/create_add1_lists.tz +++ b/src/contracts/testsuite/attic/create_add1_lists.tz @@ -2,10 +2,7 @@ parameter unit; storage address; code { DROP; NIL int; # starting storage for contract AMOUNT; # Push the starting balance - PUSH bool False; # Not spendable - DUP; # Or delegatable NONE key_hash; # No delegate - PUSH key_hash "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"; CREATE_CONTRACT # Create the contract { parameter (list int) ; storage (list int) ; diff --git a/src/contracts/testsuite/attic/create_add1_lists.tz.expected b/src/contracts/testsuite/attic/create_add1_lists.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/create_add1_lists.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/data_publisher.tz.expected b/src/contracts/testsuite/attic/data_publisher.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/data_publisher.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/dispatch.tz.expected b/src/contracts/testsuite/attic/dispatch.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/dispatch.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/empty.tz.expected b/src/contracts/testsuite/attic/empty.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/empty.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/fail_amount.tz.expected b/src/contracts/testsuite/attic/fail_amount.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/fail_amount.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/faucet.tz.expected b/src/contracts/testsuite/attic/faucet.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/faucet.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/forward.tz b/src/contracts/testsuite/attic/forward.tz index 9894dae20e94e51363a6c0446bed0ff8d04d492e..5b66891bb1bf58a42202f88b08903a81044a9bff 100644 --- a/src/contracts/testsuite/attic/forward.tz +++ b/src/contracts/testsuite/attic/forward.tz @@ -8,8 +8,8 @@ storage (pair (pair mutez mutez) # K C (pair - (pair (contract unit) (contract unit)) # B S - (contract unit))))) ; # W + (pair address address) # B S + address)))) ; # W code { DUP ; CDDADDR ; # Z PUSH int 86400 ; SWAP ; ADD ; # one day in second @@ -49,15 +49,18 @@ code IF { # refund the parties CDR ; DUP ; CADAR ; # amount versed by the buyer DIP { DUP ; CDDDAAR } ; # B + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; SWAP ; DUP ; CADDR ; # amount versed by the seller DIP { DUP ; CDDDADR } ; # S + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; DUP ; CADAR ; DIP { DUP ; CADDR } ; ADD ; BALANCE ; SUB ; # bonus to the warehouse DIP { DUP ; CDDDDR } ; # W + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; DIP { SWAP } ; CONS ; # leave the storage as-is, as the balance is now 0 @@ -101,6 +104,7 @@ code BALANCE ; DIP { DUP ; CDDDDADR } ; # S DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } { # otherwise continue @@ -110,7 +114,7 @@ code NOW ; COMPARE ; LT ; IF { # Between T + 24 and T + 48 # We accept only delivery notifications, from W - DUP ; CDDDDDR ; ADDRESS ; # W + DUP ; CDDDDDR ; # W SENDER ; COMPARE ; NEQ ; IF { FAIL } {} ; # fail if not the warehouse @@ -132,6 +136,7 @@ code BALANCE ; DIP { DUP ; CDDDDADR } ; # S DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } } ; PAIR } @@ -139,6 +144,7 @@ code BALANCE ; DIP { DUP ; CDDDDAAR } ; # B DIIP { CDR } ; + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR} } } } } } } \ No newline at end of file diff --git a/src/contracts/testsuite/attic/forward.tz.expected b/src/contracts/testsuite/attic/forward.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/forward.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/id.tz.expected b/src/contracts/testsuite/attic/id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/infinite_loop.tz.expected b/src/contracts/testsuite/attic/infinite_loop.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/infinite_loop.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/insertion_sort.tz.expected b/src/contracts/testsuite/attic/insertion_sort.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/insertion_sort.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/int_publisher.tz.expected b/src/contracts/testsuite/attic/int_publisher.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/int_publisher.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/king_of_tez.tz.expected b/src/contracts/testsuite/attic/king_of_tez.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/king_of_tez.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/list_of_transactions.tz b/src/contracts/testsuite/attic/list_of_transactions.tz index 412112aad02c58272b6ff3ff4cd6cb42362b1f47..620ceedd5a678613b004e6744347bbfe309b456e 100644 --- a/src/contracts/testsuite/attic/list_of_transactions.tz +++ b/src/contracts/testsuite/attic/list_of_transactions.tz @@ -1,8 +1,8 @@ parameter unit; -storage (list (contract unit)); +storage (list address); code { CDR; DUP; DIP {NIL operation}; PUSH bool True; # Setup loop - LOOP {IF_CONS { PUSH mutez 1000000; UNIT; TRANSFER_TOKENS; # Make transfer + LOOP {IF_CONS { CONTRACT unit ; ASSERT_SOME ; PUSH mutez 1000000; UNIT; TRANSFER_TOKENS; # Make transfer SWAP; DIP {CONS}; PUSH bool True} # Setup for next round of loop - { NIL (contract unit); PUSH bool False}}; # Data to satisfy types and end loop + { NIL address ; PUSH bool False}}; # Data to satisfy types and end loop DROP; PAIR}; # Calling convention diff --git a/src/contracts/testsuite/attic/list_of_transactions.tz.expected b/src/contracts/testsuite/attic/list_of_transactions.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/list_of_transactions.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/queue.tz.expected b/src/contracts/testsuite/attic/queue.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/queue.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/reduce_map.tz.expected b/src/contracts/testsuite/attic/reduce_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/reduce_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/reentrancy.tz b/src/contracts/testsuite/attic/reentrancy.tz index 2e5d92060ad75fef2e6f7959f7ed656bf6e2993a..b9e614a4e53e9b0772872e81a43900b5363a2a34 100644 --- a/src/contracts/testsuite/attic/reentrancy.tz +++ b/src/contracts/testsuite/attic/reentrancy.tz @@ -1,7 +1,7 @@ parameter unit; -storage (pair (contract unit) (contract unit)); -code { CDR; DUP; CAR; PUSH mutez 5000000; UNIT; - TRANSFER_TOKENS; +storage (pair address address); +code { CDR; DUP; CAR; + CONTRACT unit ; ASSERT_SOME ; PUSH mutez 5000000; UNIT; TRANSFER_TOKENS; DIP {DUP; CDR; - PUSH mutez 5000000; UNIT; TRANSFER_TOKENS}; + CONTRACT unit ; ASSERT_SOME ; PUSH mutez 5000000; UNIT; TRANSFER_TOKENS}; DIIP{NIL operation};DIP{CONS};CONS;PAIR}; diff --git a/src/contracts/testsuite/attic/reentrancy.tz.expected b/src/contracts/testsuite/attic/reentrancy.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/reentrancy.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/reservoir.tz b/src/contracts/testsuite/attic/reservoir.tz similarity index 81% rename from src/contracts/testsuite/mini_scenarios/reservoir.tz rename to src/contracts/testsuite/attic/reservoir.tz index 4e693c9ba88518abeadd87dac823fe6927d8b571..291e09b262b58110d971fa23ca8badcc1f93164f 100644 --- a/src/contracts/testsuite/mini_scenarios/reservoir.tz +++ b/src/contracts/testsuite/attic/reservoir.tz @@ -2,7 +2,7 @@ parameter unit ; storage (pair (pair (timestamp %T) (mutez %N)) - (pair (contract %A unit) (contract %B unit))) ; + (pair (address %A) (address %B))) ; code { CDR ; DUP ; CAAR %T; # T NOW ; COMPARE ; LE ; @@ -11,11 +11,13 @@ code COMPARE ; LE ; IF { NIL operation ; PAIR } { DUP ; CDDR %B; # B + CONTRACT unit ; ASSERT_SOME ; BALANCE ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } } { DUP ; CDAR %A; # A + CONTRACT unit ; ASSERT_SOME ; BALANCE ; UNIT ; TRANSFER_TOKENS ; diff --git a/src/contracts/testsuite/attic/reservoir.tz.expected b/src/contracts/testsuite/attic/reservoir.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/reservoir.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/scrutable_reservoir.tz b/src/contracts/testsuite/attic/scrutable_reservoir.tz similarity index 86% rename from src/contracts/testsuite/mini_scenarios/scrutable_reservoir.tz rename to src/contracts/testsuite/attic/scrutable_reservoir.tz index 9e30a1a72628354e58adced2c397c5daa1c7655f..d415cdda0f54950d0210a1323d157ca9d61f84fc 100644 --- a/src/contracts/testsuite/mini_scenarios/scrutable_reservoir.tz +++ b/src/contracts/testsuite/attic/scrutable_reservoir.tz @@ -7,8 +7,8 @@ storage (pair (pair mutez mutez) # P N (pair - (contract unit) # X - (pair (contract unit) (contract unit)))))) ; # A B + address # X + (pair address address))))) ; # A B code { DUP ; CDAR ; # S PUSH string "open" ; @@ -34,10 +34,12 @@ code # We transfer the fee to the broker DUP ; CDDAAR ; # P DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS ; # We transfer the rest to A DIP { DUP ; CDDADR ; # N DIP { DUP ; CDDDDAR } ; # A + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } } @@ -50,13 +52,16 @@ code COMPARE ; LT ; # available < P IF { BALANCE ; # available DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } { DUP ; CDDAAR ; # P DIP { DUP ; CDDDAR } ; # X + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; # We transfer the rest to B DIP { BALANCE ; # available DIP { DUP ; CDDDDDR } ; # B + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT ; TRANSFER_TOKENS } ; NIL operation ; SWAP ; CONS ; SWAP ; CONS ; PAIR } } } diff --git a/src/contracts/testsuite/attic/scrutable_reservoir.tz.expected b/src/contracts/testsuite/attic/scrutable_reservoir.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/scrutable_reservoir.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/attic/spawn_identities.tz b/src/contracts/testsuite/attic/spawn_identities.tz index 91b062aff83b1d8e31b0c16c3c9711aa3448d533..b8e64bb8686ac8a051a61b0b9b27c444b636c650 100644 --- a/src/contracts/testsuite/attic/spawn_identities.tz +++ b/src/contracts/testsuite/attic/spawn_identities.tz @@ -9,9 +9,7 @@ code { DUP; { PUSH nat 1; SWAP; SUB; ABS; # Subtract 1. The ABS is to make it back into a nat PUSH string "init"; # Storage type PUSH mutez 5000000; # Strating balance - PUSH bool False; DUP; # Not spendable or delegatable NONE key_hash; - PUSH key_hash "tz1cxcwwnzENRdhe2Kb8ZdTrdNy4bFNyScx5"; CREATE_CONTRACT { parameter string ; storage string ; diff --git a/src/contracts/testsuite/attic/spawn_identities.tz.expected b/src/contracts/testsuite/attic/spawn_identities.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/attic/spawn_identities.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/deprecated/create_account.tz b/src/contracts/testsuite/deprecated/create_account.tz new file mode 100644 index 0000000000000000000000000000000000000000..7cd38465a10b13126860d2e5736820ee37c3f8df --- /dev/null +++ b/src/contracts/testsuite/deprecated/create_account.tz @@ -0,0 +1,29 @@ +/* +- optional storage: the address of the created account +- param: Left [hash]: + + Create an account with manager [hash]; then perform a recursive call + on Right [addr] where [addr] is the address of the newly created + account. + + The created account has an initial balance of 100tz. It is not + delegatable. + +- param: Right [addr]: + + Check that the sender is self and that [addr] is a contract of type + [unit]. Finally store [addr]. + +*/ +parameter (or key_hash address) ; +storage (option address) ; +code { CAR; + IF_LEFT + { DIP { PUSH mutez 100000000 ; PUSH bool False ; NONE key_hash }; + CREATE_ACCOUNT ; + DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS } ; + CONS ; NONE address ; SWAP ; PAIR } + { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; + DUP ; CONTRACT unit ; IF_SOME { DROP ; SOME } { FAIL } ; + NIL operation ; PAIR } } ; diff --git a/src/contracts/testsuite/deprecated/create_account.tz.expected b/src/contracts/testsuite/deprecated/create_account.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..723cdab128491cd57b4a4789bf36c8809a4d3a23 --- /dev/null +++ b/src/contracts/testsuite/deprecated/create_account.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: KO: Unknown primitive CREATE_ACCOUNT between line 23 column 11 and line 23 column 24 +Type checking: KO: Unknown primitive CREATE_ACCOUNT between line 23 column 11 and line 23 column 24 + diff --git a/src/contracts/testsuite/deprecated/create_contract.tz b/src/contracts/testsuite/deprecated/create_contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..a162044ac62bd8c00c25bef6726f1e77b1c8e9f2 --- /dev/null +++ b/src/contracts/testsuite/deprecated/create_contract.tz @@ -0,0 +1,18 @@ +parameter (or key_hash address); +storage unit; +code { CAR; + IF_LEFT + { DIP { PUSH string "dummy"; + PUSH mutez 100000000 ; PUSH bool False ; + PUSH bool False ; NONE key_hash } ; + CREATE_CONTRACT + { parameter string ; + storage string ; + code { CAR ; NIL operation ; PAIR } } ; + DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS } ; + CONS ; UNIT ; SWAP ; PAIR } + { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; + CONTRACT string ; IF_SOME {} { FAIL } ; + PUSH mutez 0 ; PUSH string "abcdefg" ; TRANSFER_TOKENS ; + NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } }; diff --git a/src/contracts/testsuite/deprecated/create_contract.tz.expected b/src/contracts/testsuite/deprecated/create_contract.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..dbb0aef1c08053f2b8558e6797f1074725527cd7 --- /dev/null +++ b/src/contracts/testsuite/deprecated/create_contract.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: KO: Typing error + diff --git a/src/contracts/testsuite/mini_scenarios/originator.tz b/src/contracts/testsuite/deprecated/originator.tz similarity index 100% rename from src/contracts/testsuite/mini_scenarios/originator.tz rename to src/contracts/testsuite/deprecated/originator.tz diff --git a/src/contracts/testsuite/deprecated/originator.tz.expected b/src/contracts/testsuite/deprecated/originator.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..ab3773a20efdf0999b10dd3998cc594a140f54ab --- /dev/null +++ b/src/contracts/testsuite/deprecated/originator.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: KO: Unknown primitive CREATE_ACCOUNT between line 11 column 8 and line 11 column 21 +Type checking: KO: Unknown primitive CREATE_ACCOUNT between line 11 column 8 and line 11 column 21 + diff --git a/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz b/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz new file mode 100644 index 0000000000000000000000000000000000000000..d49e6257167affbe689e6b4654ccfdf4cc828240 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz @@ -0,0 +1,31 @@ +storage + (pair (big_map string nat) (big_map string nat)) ; +parameter + (or (unit %default) + (or (or %mem (string %mem_left) (string %mem_right)) + (or (or %add (pair %add_left string nat) (pair %add_right string nat)) + (or %rem (string %rem_left) (string %rem_right))))) ; +code { UNPAIR ; + IF_LEFT + { DROP ; + DUP ; CAR ; + PUSH mutez 0 ; + NONE key_hash ; + CREATE_CONTRACT + { parameter string ; + storage (big_map string nat) ; + code { UNPAIR ; DROP ; NIL operation ; PAIR }} ; + DIP { DROP } ; + NIL operation ; SWAP ; CONS ; PAIR } + { IF_LEFT + { IF_LEFT + { DIP { UNPAIR } ; DIP { DUP } ; MEM ; ASSERT } + { DIP { UNPAIR ; SWAP } ; DIP { DUP } ; MEM ; ASSERT ; SWAP } } + { IF_LEFT + { IF_LEFT + { UNPAIR ; DIIP { UNPAIR } ; DIP { SOME } ; UPDATE } + { UNPAIR ; DIIP { UNPAIR ; SWAP } ; DIP { SOME } ; UPDATE ; SWAP } } + { IF_LEFT + { DIP { UNPAIR } ; DIP { NONE nat } ; UPDATE } + { DIP { UNPAIR ; SWAP } ; DIP { NONE nat } ; UPDATE ; SWAP } } } ; + PAIR ; NIL operation ; PAIR } } diff --git a/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz.expected b/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/entrypoints/big_map_entrypoints.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/entrypoints/delegatable_target.tz b/src/contracts/testsuite/entrypoints/delegatable_target.tz new file mode 100644 index 0000000000000000000000000000000000000000..0db00f4945ed0fa3ea1c4f71607dfa45cdbe0319 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/delegatable_target.tz @@ -0,0 +1,79 @@ +# Michelson pseudo-code to transform from source script. + # This transformation adds 'set_delegate' entrypoint, e.g.: + # + # parameter ; + # storage ; + # code ; + # + # to: +parameter + (or + (or (key_hash %set_delegate) + (unit %remove_delegate)) + (or %default string nat) + ) ; + +storage + (pair + key_hash # manager + (pair string nat) + ) ; + +code { + DUP ; + CAR ; + IF_LEFT + { # 'set_delegate'/'remove_delegate' entrypoints + # Assert no token was sent: + # to send tokens, the default entry point should be used + PUSH mutez 0 ; + AMOUNT ; + ASSERT_CMPEQ ; + # Assert that the sender is the manager + DUUP ; + CDR ; + CAR ; + IMPLICIT_ACCOUNT ; ADDRESS ; + SENDER ; + IFCMPNEQ + { SENDER ; + PUSH string "Only the owner can operate." ; + PAIR ; + FAILWITH ; + } + { DIP { CDR ; NIL operation } ; + IF_LEFT + { # 'set_delegate' entrypoint + SOME ; + SET_DELEGATE ; + CONS ; + PAIR ; + } + { # 'remove_delegate' entrypoint + DROP ; + NONE key_hash ; + SET_DELEGATE ; + CONS ; + PAIR ; + } + } + } + { # Transform the inputs to the original script types + DIP { CDR ; DUP ; CDR } ; + PAIR ; + + # 'default' entrypoint - original code + { UNPAIR; + IF_LEFT + { DIP { UNPAIR ; DROP } } + { DUG 1; UNPAIR ; DIP { DROP } } ; + PAIR ; NIL operation ; PAIR } + # Transform the outputs to the new script types (manager's storage is unchanged) + SWAP ; + CAR ; + SWAP ; + UNPAIR ; + DIP { SWAP ; PAIR } ; + PAIR ; + } + } diff --git a/src/contracts/testsuite/entrypoints/delegatable_target.tz.expected b/src/contracts/testsuite/entrypoints/delegatable_target.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..6d7f6f0cafacacbeda78d0d41a452e5c93786d3f --- /dev/null +++ b/src/contracts/testsuite/entrypoints/delegatable_target.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: KO: Parsing error +Expansion: KO: Parsing error +Type checking: KO: Parsing error + diff --git a/src/contracts/testsuite/entrypoints/manager.tz b/src/contracts/testsuite/entrypoints/manager.tz new file mode 100644 index 0000000000000000000000000000000000000000..06d9b1067bf42117745ed6405bf1dbeeff6c5678 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/manager.tz @@ -0,0 +1,31 @@ +parameter + (or + (lambda %do unit (list operation)) + (unit %default)); +storage key_hash; +code + { UNPAIR ; + IF_LEFT + { # 'do' entrypoint + # Assert no token was sent: + # to send tokens, the default entry point should be used + PUSH mutez 0 ; + AMOUNT ; + ASSERT_CMPEQ ; + # Assert that the sender is the manager + DUUP ; + IMPLICIT_ACCOUNT ; + ADDRESS ; + SENDER ; + ASSERT_CMPEQ ; + # Execute the lambda argument + UNIT ; + EXEC ; + PAIR ; + } + { # 'default' entrypoint + DROP ; + NIL operation ; + PAIR ; + } + }; diff --git a/src/contracts/testsuite/entrypoints/manager.tz.expected b/src/contracts/testsuite/entrypoints/manager.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/entrypoints/manager.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/entrypoints/no_default_target.tz b/src/contracts/testsuite/entrypoints/no_default_target.tz new file mode 100644 index 0000000000000000000000000000000000000000..48d5d53df996c53390af50da8aa9193f971192d7 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/no_default_target.tz @@ -0,0 +1,11 @@ +storage (pair string nat) ; +parameter + (or unit (or %data string nat)) ; +code { UNPAIR ; + IF_LEFT + { DROP ; NIL operation ; PAIR } + { IF_LEFT + { DIP { UNPAIR ; DROP } } + { DUG 1; UNPAIR ; DIP { DROP } } ; + PAIR ; NIL operation ; PAIR } + } diff --git a/src/contracts/testsuite/entrypoints/no_default_target.tz.expected b/src/contracts/testsuite/entrypoints/no_default_target.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/entrypoints/no_default_target.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz b/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz new file mode 100644 index 0000000000000000000000000000000000000000..d8041507d58cdc79011efa6a1e8d2c7e80c64074 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz @@ -0,0 +1,11 @@ +storage (pair string nat) ; +parameter + (or unit (or string nat)) ; +code { UNPAIR ; + IF_LEFT + { DROP ; NIL operation ; PAIR } + { IF_LEFT + { DIP { UNPAIR ; DROP } } + { DUG 1; UNPAIR ; DIP { DROP } } ; + PAIR ; NIL operation ; PAIR } + } diff --git a/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz.expected b/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/entrypoints/no_entrypoint_target.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/entrypoints/rooted_target.tz b/src/contracts/testsuite/entrypoints/rooted_target.tz new file mode 100644 index 0000000000000000000000000000000000000000..2ca2dfb1296d906e87eac5148882b62afce3cd33 --- /dev/null +++ b/src/contracts/testsuite/entrypoints/rooted_target.tz @@ -0,0 +1,11 @@ +storage (pair string nat) ; +parameter + (or %root unit (or %default string nat)) ; +code { UNPAIR ; + IF_LEFT + { DROP ; NIL operation ; PAIR } + { IF_LEFT + { DIP { UNPAIR ; DROP } } + { DUG 1; UNPAIR ; DIP { DROP } } ; + PAIR ; NIL operation ; PAIR } + } diff --git a/src/contracts/testsuite/entrypoints/rooted_target.tz.expected b/src/contracts/testsuite/entrypoints/rooted_target.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/entrypoints/rooted_target.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/ill_typed/big_map_arity.tz b/src/contracts/testsuite/ill_typed/big_map_arity.tz new file mode 100644 index 0000000000000000000000000000000000000000..5e5a7d60d5b75bb33bfcf750761b19ddde5b8756 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/big_map_arity.tz @@ -0,0 +1,5 @@ +# This contract tests the error message in case the EMPTY_BIG_MAP instruction has bad arity (1 argument instead of 2). +# The expected type-checking error is "primitive EMPTY_BIG_MAP expects 2 arguments but is given 1." +parameter unit; +storage unit; +code { DROP; EMPTY_BIG_MAP nat; DROP; UNIT; NIL operation; PAIR; } diff --git a/src/contracts/testsuite/ill_typed/big_map_arity.tz.expected b/src/contracts/testsuite/ill_typed/big_map_arity.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..307ace294ef9dd78f60073a43bc9c92bd95816c6 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/big_map_arity.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: KO: Unknown primitive EMPTY_BIG_MAP between line 5 column 10 and line 5 column 25 +Type checking: KO: Unknown primitive EMPTY_BIG_MAP between line 5 column 10 and line 5 column 25 + diff --git a/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz b/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz new file mode 100644 index 0000000000000000000000000000000000000000..4fac9c63504479d2ef42a60e275af3d495aea371 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz @@ -0,0 +1,10 @@ +parameter (or (or (nat %A) (bool %B)) (or %maybe_C (unit %Z) (string %C))); +storage unit; +code { + DROP; + # This entrypoint does not exist + SELF %D; DROP; + UNIT; + NIL operation; + PAIR; + } diff --git a/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz.expected b/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/ill_typed/invalid_self_entrypoint.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz b/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz new file mode 100644 index 0000000000000000000000000000000000000000..14fcc73411c76d7f2719969be63aca805b9cb284 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz @@ -0,0 +1,14 @@ +# tests that merging comparable pair types works +parameter (set (pair (nat %n) (pair %p (string %s) (int %i)))); +storage nat; +code {UNPAIR; + SWAP; + PUSH nat 3; + COMPARE; + GT; + IF {} + {DROP; + EMPTY_SET (pair nat (pair string int));}; + SIZE; + NIL operation; + PAIR;} diff --git a/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz.expected b/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/ill_typed/merge_comparable_pairs.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/ill_typed/pack_big_map.tz b/src/contracts/testsuite/ill_typed/pack_big_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..29ae0d665051f298be07fa7d7b1e216e3551b362 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/pack_big_map.tz @@ -0,0 +1,7 @@ +parameter unit; +storage (pair (big_map int int) unit); +code { CDAR; + DUP; PACK; DROP; + UNIT; SWAP; PAIR; + NIL operation; + PAIR; } diff --git a/src/contracts/testsuite/ill_typed/pack_big_map.tz.expected b/src/contracts/testsuite/ill_typed/pack_big_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/ill_typed/pack_big_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/ill_typed/pack_operation.tz b/src/contracts/testsuite/ill_typed/pack_operation.tz new file mode 100644 index 0000000000000000000000000000000000000000..349ca053af27cf00e200a29cb79b957e3ad51e68 --- /dev/null +++ b/src/contracts/testsuite/ill_typed/pack_operation.tz @@ -0,0 +1,20 @@ +parameter unit; +storage unit; +code { DROP; + UNIT; # starting storage for contract + AMOUNT; # Push the starting balance + NONE key_hash; # No delegate + CREATE_CONTRACT # Create the contract + { parameter unit ; + storage unit ; + code + { CDR; + NIL operation; + PAIR; } }; + DIP { DROP }; + # invalid PACK + PACK; + DROP; + UNIT; + NIL operation; + PAIR; } diff --git a/src/contracts/testsuite/ill_typed/pack_operation.tz.expected b/src/contracts/testsuite/ill_typed/pack_operation.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/ill_typed/pack_operation.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert.tz.expected b/src/contracts/testsuite/macros/assert.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmpeq.tz.expected b/src/contracts/testsuite/macros/assert_cmpeq.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmpeq.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmpge.tz.expected b/src/contracts/testsuite/macros/assert_cmpge.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmpge.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmpgt.tz.expected b/src/contracts/testsuite/macros/assert_cmpgt.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmpgt.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmple.tz.expected b/src/contracts/testsuite/macros/assert_cmple.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmple.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmplt.tz.expected b/src/contracts/testsuite/macros/assert_cmplt.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmplt.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_cmpneq.tz.expected b/src/contracts/testsuite/macros/assert_cmpneq.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_cmpneq.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_eq.tz.expected b/src/contracts/testsuite/macros/assert_eq.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_eq.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_ge.tz.expected b/src/contracts/testsuite/macros/assert_ge.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_ge.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_gt.tz.expected b/src/contracts/testsuite/macros/assert_gt.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_gt.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_le.tz.expected b/src/contracts/testsuite/macros/assert_le.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_le.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_lt.tz.expected b/src/contracts/testsuite/macros/assert_lt.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_lt.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/assert_neq.tz.expected b/src/contracts/testsuite/macros/assert_neq.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/assert_neq.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/big_map_get_add.tz.expected b/src/contracts/testsuite/macros/big_map_get_add.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/big_map_get_add.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/big_map_mem.tz.expected b/src/contracts/testsuite/macros/big_map_mem.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/big_map_mem.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/build_list.tz.expected b/src/contracts/testsuite/macros/build_list.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/build_list.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/compare.tz.expected b/src/contracts/testsuite/macros/compare.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/compare.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/compare_bytes.tz.expected b/src/contracts/testsuite/macros/compare_bytes.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/compare_bytes.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/fail.tz.expected b/src/contracts/testsuite/macros/fail.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/fail.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/guestbook.tz.expected b/src/contracts/testsuite/macros/guestbook.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/guestbook.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/macro_annotations.tz.expected b/src/contracts/testsuite/macros/macro_annotations.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/macro_annotations.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/map_caddaadr.tz.expected b/src/contracts/testsuite/macros/map_caddaadr.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/map_caddaadr.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/max_in_list.tz.expected b/src/contracts/testsuite/macros/max_in_list.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/max_in_list.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/min.tz.expected b/src/contracts/testsuite/macros/min.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/min.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/pair_macro.tz.expected b/src/contracts/testsuite/macros/pair_macro.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/pair_macro.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/set_caddaadr.tz.expected b/src/contracts/testsuite/macros/set_caddaadr.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/set_caddaadr.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/take_my_money.tz.expected b/src/contracts/testsuite/macros/take_my_money.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/take_my_money.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/macros/unpair_macro.tz.expected b/src/contracts/testsuite/macros/unpair_macro.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/macros/unpair_macro.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/authentication.tz b/src/contracts/testsuite/mini_scenarios/authentication.tz new file mode 100644 index 0000000000000000000000000000000000000000..021bbd26361a4c38df8cc3a2c7d0748f9ad6420a --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/authentication.tz @@ -0,0 +1,30 @@ +/* + +This contract is an example of using a cryptographic signature to +handle authentication. A public key is stored, and only the owner of +the secret key associated to this public key can interact with the +contract. She is allowed to perform any list of operations by sending +them wrapped in a lambda to the contract with a cryptographic +signature. + +To ensure that each signature is used only once and is not replayed by +an attacker, not only the lambda is signed but also the unique +identifier of the contract (a pair of the contract address and the +chain id) and a counter that is incremented at each successful call. + +More precisely, the signature should check against pack ((chain_id, +self) (param, counter)). + +*/ +parameter (pair (lambda unit (list operation)) signature); +storage (pair (nat %counter) key); +code + { + UNPPAIPAIR; + DUUUP; DUUP ; SELF; CHAIN_ID ; PPAIPAIR; PACK; + DIP { SWAP }; DUUUUUP ; DIP { SWAP }; + DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH}; + UNIT; EXEC; + DIP { PUSH nat 1; ADD }; + PAPAIR + } diff --git a/src/contracts/testsuite/mini_scenarios/authentication.tz.expected b/src/contracts/testsuite/mini_scenarios/authentication.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/authentication.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz b/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz new file mode 100644 index 0000000000000000000000000000000000000000..d49e6257167affbe689e6b4654ccfdf4cc828240 --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz @@ -0,0 +1,31 @@ +storage + (pair (big_map string nat) (big_map string nat)) ; +parameter + (or (unit %default) + (or (or %mem (string %mem_left) (string %mem_right)) + (or (or %add (pair %add_left string nat) (pair %add_right string nat)) + (or %rem (string %rem_left) (string %rem_right))))) ; +code { UNPAIR ; + IF_LEFT + { DROP ; + DUP ; CAR ; + PUSH mutez 0 ; + NONE key_hash ; + CREATE_CONTRACT + { parameter string ; + storage (big_map string nat) ; + code { UNPAIR ; DROP ; NIL operation ; PAIR }} ; + DIP { DROP } ; + NIL operation ; SWAP ; CONS ; PAIR } + { IF_LEFT + { IF_LEFT + { DIP { UNPAIR } ; DIP { DUP } ; MEM ; ASSERT } + { DIP { UNPAIR ; SWAP } ; DIP { DUP } ; MEM ; ASSERT ; SWAP } } + { IF_LEFT + { IF_LEFT + { UNPAIR ; DIIP { UNPAIR } ; DIP { SOME } ; UPDATE } + { UNPAIR ; DIIP { UNPAIR ; SWAP } ; DIP { SOME } ; UPDATE ; SWAP } } + { IF_LEFT + { DIP { UNPAIR } ; DIP { NONE nat } ; UPDATE } + { DIP { UNPAIR ; SWAP } ; DIP { NONE nat } ; UPDATE ; SWAP } } } ; + PAIR ; NIL operation ; PAIR } } diff --git a/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz.expected b/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/big_map_entrypoints.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/big_map_magic.tz b/src/contracts/testsuite/mini_scenarios/big_map_magic.tz new file mode 100644 index 0000000000000000000000000000000000000000..f4e36f639bff585fc876dc87fa08cd2e575b1a38 --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/big_map_magic.tz @@ -0,0 +1,41 @@ +# this contracts handles two big_maps +storage + (or (pair (big_map string string) (big_map string string)) unit) ; +parameter + # it has 5 entry points + # swap: swaps the two maps. + (or (unit %swap) + # reset: resets storage, either to a new pair of maps, or to unit + (or (or %reset (pair (big_map string string) (big_map string string)) unit) + # import: drops the existing storage and creates two maps + # from the given lists of string pairs. + (or (pair %import (list (pair string string)) (list (pair string string))) + # add: adds the given list of key - value pairs into the + # first map + (or (list %add (pair string string)) + # rem: removes the given list of key - value pairs + # from the first map + (list %rem string))))) ; +code { UNPAIR ; + IF_LEFT + { DROP ; ASSERT_LEFT ; UNPAIR ; SWAP ; PAIR ; LEFT unit } + { IF_LEFT + { SWAP ; DROP } + { IF_LEFT + { DIP { ASSERT_RIGHT ; DROP } ; + UNPAIR ; + DIP { EMPTY_BIG_MAP string string } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + SWAP ; + DIP { EMPTY_BIG_MAP string string } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + SWAP ; + PAIR ; LEFT unit } + { IF_LEFT + { DIP { ASSERT_LEFT ; UNPAIR } ; + ITER { UNPAIR ; DIP { SOME } ; UPDATE } ; + PAIR ; LEFT unit } + { DIP { ASSERT_LEFT ; UNPAIR } ; + ITER { DIP { NONE string } ; UPDATE } ; + PAIR ; LEFT unit } }} } ; + NIL operation ; PAIR } \ No newline at end of file diff --git a/src/contracts/testsuite/mini_scenarios/big_map_magic.tz.expected b/src/contracts/testsuite/mini_scenarios/big_map_magic.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/big_map_magic.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/create_account.tz b/src/contracts/testsuite/mini_scenarios/create_account.tz deleted file mode 100644 index 6d0d261ec4eced95714fba5811a4f64f16091422..0000000000000000000000000000000000000000 --- a/src/contracts/testsuite/mini_scenarios/create_account.tz +++ /dev/null @@ -1,12 +0,0 @@ -parameter (or key_hash address) ; -storage (option (contract unit)) ; -code { CAR; - IF_LEFT - { DIP { PUSH mutez 100000000 ; PUSH bool False ; NONE key_hash }; - CREATE_ACCOUNT ; - DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; - NIL operation ; SWAP ; CONS } ; - CONS ; NONE (contract unit) ; SWAP ; PAIR } - { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; - CONTRACT unit ; DUP ; IF_SOME { DROP } { FAIL } ; - NIL operation ; PAIR } } ; diff --git a/src/contracts/testsuite/mini_scenarios/create_contract.tz b/src/contracts/testsuite/mini_scenarios/create_contract.tz index a162044ac62bd8c00c25bef6726f1e77b1c8e9f2..0d09a1fdfca61fdf33504ef20bdc9d0d209b6aaf 100644 --- a/src/contracts/testsuite/mini_scenarios/create_contract.tz +++ b/src/contracts/testsuite/mini_scenarios/create_contract.tz @@ -1,18 +1,33 @@ -parameter (or key_hash address); -storage unit; -code { CAR; - IF_LEFT - { DIP { PUSH string "dummy"; - PUSH mutez 100000000 ; PUSH bool False ; - PUSH bool False ; NONE key_hash } ; +/* +- param: None: + + Create a contract then perform a recursive call on Some [addr] where + [addr] is the address of the newly created contract. + + The created contract simply stores its parameter (a string). It is + initialized with the storage "dummy" and has an initial balance of + 100tz. It has no delegate so these 100tz are totally frozen. + +- param: Some [addr]: + + Check that the sender is self, call the contract at address [addr] + with param "abcdefg" transferring 0tz. + +*/ +parameter (option address) ; +storage unit ; +code { CAR ; + IF_NONE + { PUSH string "dummy" ; + PUSH mutez 100000000 ; NONE key_hash ; CREATE_CONTRACT { parameter string ; storage string ; code { CAR ; NIL operation ; PAIR } } ; - DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + DIP { SOME ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS } ; CONS ; UNIT ; SWAP ; PAIR } { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ; CONTRACT string ; IF_SOME {} { FAIL } ; PUSH mutez 0 ; PUSH string "abcdefg" ; TRANSFER_TOKENS ; - NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } }; + NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } } ; \ No newline at end of file diff --git a/src/contracts/testsuite/mini_scenarios/create_contract.tz.expected b/src/contracts/testsuite/mini_scenarios/create_contract.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/create_contract.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz b/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz new file mode 100644 index 0000000000000000000000000000000000000000..2a5185d748895a41bd9552103d42176ff965baea --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz @@ -0,0 +1,14 @@ +parameter unit; +storage unit; +code { CAR; + PUSH string "foo"; + PUSH mutez 0; + NONE key_hash; + CREATE_CONTRACT + { parameter string ; + storage string ; + code { CAR ; NIL operation ; PAIR } } ; + DROP; DROP; + NIL operation; + PAIR; + } diff --git a/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz.expected b/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/create_contract_simple.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/default_account.tz b/src/contracts/testsuite/mini_scenarios/default_account.tz index db9f01156c6822310dbe2b792f76ab0c6f882f6f..74e7693d7ba52ecc77d7b20e24590cbae32570cd 100644 --- a/src/contracts/testsuite/mini_scenarios/default_account.tz +++ b/src/contracts/testsuite/mini_scenarios/default_account.tz @@ -1,3 +1,7 @@ +/* +Send 100 tz to the implicit account given as parameter. +*/ + parameter key_hash; storage unit; code {DIP{UNIT}; CAR; IMPLICIT_ACCOUNT; diff --git a/src/contracts/testsuite/mini_scenarios/default_account.tz.expected b/src/contracts/testsuite/mini_scenarios/default_account.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/default_account.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/hardlimit.tz.expected b/src/contracts/testsuite/mini_scenarios/hardlimit.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/hardlimit.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/lockup.tz b/src/contracts/testsuite/mini_scenarios/lockup.tz index a68a8628f25c846a3fd4460fe6278248d0113ab8..eb238fd654fe1dae92ebd0917519f5d0027409da 100644 --- a/src/contracts/testsuite/mini_scenarios/lockup.tz +++ b/src/contracts/testsuite/mini_scenarios/lockup.tz @@ -1,5 +1,5 @@ parameter unit; -storage (pair timestamp (pair mutez (contract unit))); +storage (pair timestamp (pair mutez address)); code { CDR; # Ignore the parameter DUP; # Duplicate the storage CAR; # Get the timestamp @@ -12,6 +12,7 @@ code { CDR; # Ignore the parameter DUP; # Duplicate the transfer information CAR; # Get the amount of the transfer on top of the stack DIP{CDR}; # Put the contract underneath it + DIP { CONTRACT unit ; ASSERT_SOME } ; UNIT; # Put the contract's argument type on top of the stack TRANSFER_TOKENS; # Emit the transfer NIL operation; SWAP; CONS;# Make a singleton list of internal operations diff --git a/src/contracts/testsuite/mini_scenarios/lockup.tz.expected b/src/contracts/testsuite/mini_scenarios/lockup.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/lockup.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/multiple_en2.tz b/src/contracts/testsuite/mini_scenarios/multiple_en2.tz new file mode 100644 index 0000000000000000000000000000000000000000..a1acafd48706d86b5bbd614f2922d52b109edf10 --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/multiple_en2.tz @@ -0,0 +1,77 @@ +{ parameter unit ; + storage (option address) ; + code { SENDER ; + SELF ; + ADDRESS ; + { COMPARE ; + EQ ; + IF { CDR ; + { IF_NONE { { UNIT ; FAILWITH } } {} } ; + DIP { NIL operation } ; + DUP ; + CONTRACT %add unit ; + { IF_NONE {} { { UNIT ; FAILWITH } } } ; + DUP ; + CONTRACT %fact nat ; + { IF_NONE {} { { UNIT ; FAILWITH } } } ; + DUP ; + CONTRACT %add nat ; + { IF_NONE { { UNIT ; FAILWITH } } {} } ; + PUSH mutez 0 ; + PUSH nat 12 ; + TRANSFER_TOKENS ; + SWAP ; + DIP { CONS } ; + DUP ; + CONTRACT unit ; + { IF_NONE { { UNIT ; FAILWITH } } {} } ; + PUSH mutez 0 ; + PUSH unit Unit ; + TRANSFER_TOKENS ; + SWAP ; + DIP { CONS } ; + DUP ; + CONTRACT %sub nat ; + { IF_NONE { { UNIT ; FAILWITH } } {} } ; + PUSH mutez 0 ; + PUSH nat 3 ; + TRANSFER_TOKENS ; + SWAP ; + DIP { CONS } ; + DUP ; + CONTRACT %add nat ; + { IF_NONE { { UNIT ; FAILWITH } } {} } ; + PUSH mutez 0 ; + PUSH nat 5 ; + TRANSFER_TOKENS ; + SWAP ; + DIP { CONS } ; + DROP ; + DIP { NONE address } ; + PAIR } + { CAR ; + DUP ; + DIP { DIP { PUSH int 0 ; PUSH mutez 0 ; NONE key_hash } ; + DROP ; + CREATE_CONTRACT + { parameter (or (or (nat %add) (nat %sub)) (unit %default)) ; + storage int ; + code { AMOUNT ; + PUSH mutez 0 ; + { { COMPARE ; EQ } ; IF {} { { UNIT ; FAILWITH } } } ; + { { DUP ; CAR ; DIP { CDR } } } ; + IF_LEFT + { IF_LEFT { ADD } { SWAP ; SUB } } + { DROP ; DROP ; PUSH int 0 } ; + NIL operation ; + PAIR } } } ; + DIP { SELF ; PUSH mutez 0 } ; + TRANSFER_TOKENS ; + NIL operation ; + SWAP ; + CONS ; + SWAP ; + CONS ; + DIP { SOME } ; + PAIR } } + } } diff --git a/src/contracts/testsuite/mini_scenarios/multiple_en2.tz.expected b/src/contracts/testsuite/mini_scenarios/multiple_en2.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/multiple_en2.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz b/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz new file mode 100644 index 0000000000000000000000000000000000000000..740190697171aa8c5944e5b361127d75d5ba74aa --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz @@ -0,0 +1,29 @@ +{ parameter unit ; + storage (option address) ; + code { SENDER ; SELF ; ADDRESS ; + IFCMPEQ + { CDR ; ASSERT_SOME ; + DIP { NIL operation } ; + DUP ; CONTRACT %add unit ; ASSERT_NONE ; + DUP ; CONTRACT %fact nat ; ASSERT_NONE ; + DUP ; CONTRACT %add nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 12 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT unit ; ASSERT_SOME ; PUSH mutez 0 ; PUSH unit Unit ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT %sub nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 3 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DUP ; CONTRACT %add nat ; ASSERT_SOME ; PUSH mutez 0 ; PUSH nat 5 ; TRANSFER_TOKENS ; SWAP ; DIP { CONS } ; + DROP ; DIP { NONE address } ; PAIR } + { CAR ; DUP ; + DIP + { DIP { PUSH int 0 ; PUSH mutez 0 ; NONE key_hash } ; + DROP ; + CREATE_CONTRACT + { parameter (or (or (nat %add) (nat %sub)) (unit %default)) ; + storage int ; + code { AMOUNT ; PUSH mutez 0 ; ASSERT_CMPEQ ; + UNPAIR ; + IF_LEFT + { IF_LEFT { ADD } { SWAP ; SUB } } + { DROP ; DROP ; PUSH int 0 } ; + NIL operation ; PAIR } } } ; + DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ; + NIL operation ; SWAP ; CONS ; SWAP ; CONS ; + DIP { SOME } ; PAIR } } } \ No newline at end of file diff --git a/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz.expected b/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/multiple_entrypoints_counter.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/parameterized_multisig.tz.expected b/src/contracts/testsuite/mini_scenarios/parameterized_multisig.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/parameterized_multisig.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/replay.tz b/src/contracts/testsuite/mini_scenarios/replay.tz index d00e368d9e1d62780133279dc799c1c72b6b8fd1..73ac145abae36ad2dcbd012968456fc25059e139 100644 --- a/src/contracts/testsuite/mini_scenarios/replay.tz +++ b/src/contracts/testsuite/mini_scenarios/replay.tz @@ -1,3 +1,4 @@ +# This contract always fail because it tries to execute twice the same operation parameter unit ; storage unit ; code { CDR ; NIL operation ; diff --git a/src/contracts/testsuite/mini_scenarios/replay.tz.expected b/src/contracts/testsuite/mini_scenarios/replay.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/replay.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz b/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz index 520707c60e2b5bb495d47890335cea534d21f36a..1a7e97eb8a68cd7d89b28be6b243107b18494c2f 100644 --- a/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz +++ b/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz @@ -1,7 +1,13 @@ parameter (pair bytes signature) ; storage (pair bytes key) ; -code { DUP ; UNPAIR ; CAR ; SHA256 ; DIP { CAR } ; ASSERT_CMPEQ ; +code { + #check that sha256(param.bytes) == storage.bytes + DUP ; UNPAIR ; CAR; SHA256; DIP { CAR } ; ASSERT_CMPEQ ; + + # check that the sig is a valid signature of the preimage DUP ; UNPAIR ; SWAP ; DIP { UNPAIR ; SWAP } ; CDR ; CHECK_SIGNATURE ; ASSERT ; + + # send all our tokens to the implicit account corresponding to the stored public key CDR ; DUP ; CDR ; HASH_KEY ; IMPLICIT_ACCOUNT ; BALANCE ; UNIT ; TRANSFER_TOKENS ; NIL operation ; SWAP ; CONS ; PAIR } \ No newline at end of file diff --git a/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz.expected b/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/reveal_signed_preimage.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/vote_for_delegate.tz.expected b/src/contracts/testsuite/mini_scenarios/vote_for_delegate.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/vote_for_delegate.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/weather_insurance.tz b/src/contracts/testsuite/mini_scenarios/weather_insurance.tz index 858fe918fa504d2fe3246fdaee7daad8fd184503..e7e99e0183355889dd9bbf2087d4a885e550c37d 100644 --- a/src/contracts/testsuite/mini_scenarios/weather_insurance.tz +++ b/src/contracts/testsuite/mini_scenarios/weather_insurance.tz @@ -1,7 +1,7 @@ parameter (pair (signature %signed_weather_data) (nat :rain %actual_level)); # (pair (under_key over_key) (pair weather_service_key (pair rain_level days_in_future))) -storage (pair (pair (contract %under_key unit) - (contract %over_key unit)) +storage (pair (pair (address %under_key) + (address %over_key)) (pair (nat :rain %rain_level) (key %weather_service_key))); code { DUP; DUP; CAR; MAP_CDR{PACK ; BLAKE2B}; @@ -13,6 +13,7 @@ code { DUP; DUP; DIP{CADR %actual_level}; # Get actual rain CDDAR %rain_level; # Get rain threshold CMPLT; IF {CAR %under_key} {CDR %over_key}; # Select contract to receive tokens + CONTRACT unit ; ASSERT_SOME ; BALANCE; UNIT ; TRANSFER_TOKENS @trans.op; # Setup and execute transfer NIL operation ; SWAP ; CONS ; PAIR }; diff --git a/src/contracts/testsuite/mini_scenarios/weather_insurance.tz.expected b/src/contracts/testsuite/mini_scenarios/weather_insurance.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/weather_insurance.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/xcat.tz b/src/contracts/testsuite/mini_scenarios/xcat.tz index 254f4d825283bf01a45e2314144a54f4f7cc552c..83e6c7ac1d50fb81328152ca69aba539c96934b3 100644 --- a/src/contracts/testsuite/mini_scenarios/xcat.tz +++ b/src/contracts/testsuite/mini_scenarios/xcat.tz @@ -9,8 +9,10 @@ code { # There's a temptation to use @storage to parametrize # a contract but, in general, there's no reason to encumber # @storage with immutable values. - PUSH @from (contract unit) "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; #changeme - PUSH @to (contract unit) "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN"; #changeme + PUSH @from key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; #changeme + IMPLICIT_ACCOUNT ; + PUSH @to key_hash "tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN"; #changeme + IMPLICIT_ACCOUNT ; PUSH @target_hash bytes 0x123456; #changeme PUSH @deadline timestamp "2018-08-08 00:00:00Z"; #changeme }; diff --git a/src/contracts/testsuite/mini_scenarios/xcat.tz.expected b/src/contracts/testsuite/mini_scenarios/xcat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/xcat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/mini_scenarios/xcat_dapp.tz.expected b/src/contracts/testsuite/mini_scenarios/xcat_dapp.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/mini_scenarios/xcat_dapp.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/non_regression/bug_262.tz b/src/contracts/testsuite/non_regression/bug_262.tz new file mode 100644 index 0000000000000000000000000000000000000000..63475c5ac18525abe6c0467098039ba75a4e2edc --- /dev/null +++ b/src/contracts/testsuite/non_regression/bug_262.tz @@ -0,0 +1,5 @@ +{ parameter unit ; + storage unit ; + code { DROP ; + LAMBDA unit unit {} ; UNIT ; EXEC ; + NIL operation ; PAIR } } \ No newline at end of file diff --git a/src/contracts/testsuite/non_regression/bug_262.tz.expected b/src/contracts/testsuite/non_regression/bug_262.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/non_regression/bug_262.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/abs.tz b/src/contracts/testsuite/opcodes/abs.tz new file mode 100644 index 0000000000000000000000000000000000000000..d03d0883fe73e67ec19a02e24365c00ab583a0d7 --- /dev/null +++ b/src/contracts/testsuite/opcodes/abs.tz @@ -0,0 +1,5 @@ +parameter nat; +storage unit; +code { CAR; + DUP; NEG; ABS; COMPARE; ASSERT_EQ; + UNIT; NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/abs.tz.expected b/src/contracts/testsuite/opcodes/abs.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/abs.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/add.tz b/src/contracts/testsuite/opcodes/add.tz new file mode 100644 index 0000000000000000000000000000000000000000..cbefea08a7a422651a01695368440733b093eb05 --- /dev/null +++ b/src/contracts/testsuite/opcodes/add.tz @@ -0,0 +1,25 @@ +parameter unit; +storage unit; +code + { + CAR; + + PUSH int 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH int 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH int 2; PUSH nat 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH nat 2; PUSH int 2; ADD; PUSH int 4; ASSERT_CMPEQ; + PUSH nat 2; PUSH nat 2; ADD; PUSH nat 4; ASSERT_CMPEQ; + + # Offset a timestamp by 60 seconds + PUSH int 60; PUSH timestamp "2019-09-09T12:08:37Z"; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH timestamp "2019-09-09T12:08:37Z"; PUSH int 60; ADD; + PUSH timestamp "2019-09-09T12:09:37Z"; ASSERT_CMPEQ; + + PUSH mutez 1000; PUSH mutez 1000; ADD; + PUSH mutez 2000; ASSERT_CMPEQ; + + NIL operation; + PAIR; + } diff --git a/src/contracts/testsuite/opcodes/add.tz.expected b/src/contracts/testsuite/opcodes/add.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/add.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/add_delta_timestamp.tz.expected b/src/contracts/testsuite/opcodes/add_delta_timestamp.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/add_delta_timestamp.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/add_timestamp_delta.tz.expected b/src/contracts/testsuite/opcodes/add_timestamp_delta.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/add_timestamp_delta.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/address.tz b/src/contracts/testsuite/opcodes/address.tz new file mode 100644 index 0000000000000000000000000000000000000000..7e6bcdec337b40cdd784165818713bccc652d6f4 --- /dev/null +++ b/src/contracts/testsuite/opcodes/address.tz @@ -0,0 +1,3 @@ +parameter (contract unit); +storage (option address); +code {CAR; ADDRESS; SOME; NIL operation; PAIR } diff --git a/src/contracts/testsuite/opcodes/address.tz.expected b/src/contracts/testsuite/opcodes/address.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/address.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/and.tz.expected b/src/contracts/testsuite/opcodes/and.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/and.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/and_binary.tz b/src/contracts/testsuite/opcodes/and_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..96f60082c713bcefd9eca89e2f890a8251ce8c78 --- /dev/null +++ b/src/contracts/testsuite/opcodes/and_binary.tz @@ -0,0 +1,27 @@ +parameter unit; +storage unit; +code { DROP; + + # 0101 & 0110 = 0100 + PUSH nat 5; PUSH nat 6; AND; PUSH nat 4; ASSERT_CMPEQ; + + # 0110 & 0101 = 0100 + PUSH nat 6; PUSH int 5; AND; PUSH nat 4; ASSERT_CMPEQ; + + # Negative numbers are represented as with a initial virtual + # infinite series of 1's. + # Hence, AND with -1 (1111...) is identity: + + # 12 = ...1100 + # & -1 = ...1111 + # ---- + # = 12 = ...1100 + PUSH nat 12; PUSH int -1; AND; PUSH nat 12; ASSERT_CMPEQ; + + # 12 = ...0001100 + # & -5 = ...1111011 + # ----------------- + # 8 = ...0001000 + PUSH nat 12; PUSH int -5; AND; PUSH nat 8; ASSERT_CMPEQ; + + UNIT; NIL @noop operation; PAIR; }; diff --git a/src/contracts/testsuite/opcodes/and_binary.tz.expected b/src/contracts/testsuite/opcodes/and_binary.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/and_binary.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/and_logical_1.tz b/src/contracts/testsuite/opcodes/and_logical_1.tz new file mode 100644 index 0000000000000000000000000000000000000000..20743c0bfdf9118f513ee58d7191c94ec2a71be8 --- /dev/null +++ b/src/contracts/testsuite/opcodes/and_logical_1.tz @@ -0,0 +1,3 @@ +parameter (pair bool bool); +storage bool; +code { CAR ; UNPAIR; AND @and; NIL @noop operation; PAIR; }; diff --git a/src/contracts/testsuite/opcodes/and_logical_1.tz.expected b/src/contracts/testsuite/opcodes/and_logical_1.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/and_logical_1.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/balance.tz.expected b/src/contracts/testsuite/opcodes/balance.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/balance.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/big_map_mem_nat.tz b/src/contracts/testsuite/opcodes/big_map_mem_nat.tz new file mode 100644 index 0000000000000000000000000000000000000000..71ecaf2c4a754ea20a1f802f0e3c6401914a7e5e --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_mem_nat.tz @@ -0,0 +1,7 @@ +parameter nat; +storage (pair (big_map nat nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/contracts/testsuite/opcodes/big_map_mem_nat.tz.expected b/src/contracts/testsuite/opcodes/big_map_mem_nat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_mem_nat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/big_map_mem_string.tz b/src/contracts/testsuite/opcodes/big_map_mem_string.tz new file mode 100644 index 0000000000000000000000000000000000000000..8c557f7dc1f8ff5ee260794ab094576252c56724 --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_mem_string.tz @@ -0,0 +1,7 @@ +parameter string; +storage (pair (big_map string nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/contracts/testsuite/opcodes/big_map_mem_string.tz.expected b/src/contracts/testsuite/opcodes/big_map_mem_string.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_mem_string.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/big_map_to_self.tz b/src/contracts/testsuite/opcodes/big_map_to_self.tz new file mode 100644 index 0000000000000000000000000000000000000000..6a9442b9f3e5e149af21b348323b212ad8ea664c --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_to_self.tz @@ -0,0 +1,22 @@ +parameter (or (pair %have_fun (big_map string nat) unit) (unit %default)); +storage (big_map string nat); +code { + UNPAIR; + DIP {NIL operation}; + IF_LEFT { + DROP + } + { + DROP; + SELF %have_fun; + PUSH mutez 0; + DUP 4; + PUSH (option nat) (Some 8); + PUSH string "hahaha"; + UPDATE; + UNIT; SWAP; PAIR; + TRANSFER_TOKENS; + CONS + }; + PAIR + } diff --git a/src/contracts/testsuite/opcodes/big_map_to_self.tz.expected b/src/contracts/testsuite/opcodes/big_map_to_self.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..dbb0aef1c08053f2b8558e6797f1074725527cd7 --- /dev/null +++ b/src/contracts/testsuite/opcodes/big_map_to_self.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: KO: Typing error + diff --git a/src/contracts/testsuite/opcodes/car.tz b/src/contracts/testsuite/opcodes/car.tz new file mode 100644 index 0000000000000000000000000000000000000000..8fd03ba5105277a2cf4dfedfe09eaf748b4031c3 --- /dev/null +++ b/src/contracts/testsuite/opcodes/car.tz @@ -0,0 +1,3 @@ +parameter (pair (nat :l) (nat :r)); +storage nat; +code { CAR; CAR ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/car.tz.expected b/src/contracts/testsuite/opcodes/car.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/car.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/cdr.tz b/src/contracts/testsuite/opcodes/cdr.tz new file mode 100644 index 0000000000000000000000000000000000000000..dae260c5be74cdf18a0380f2c2e75f6be0e47152 --- /dev/null +++ b/src/contracts/testsuite/opcodes/cdr.tz @@ -0,0 +1,3 @@ +parameter (pair (nat :l) (nat :r)); +storage nat; +code { CAR; CDR ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/cdr.tz.expected b/src/contracts/testsuite/opcodes/cdr.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/cdr.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/chain_id.tz b/src/contracts/testsuite/opcodes/chain_id.tz new file mode 100644 index 0000000000000000000000000000000000000000..783d13fa0afc22f0b8e9701152e1420635cf7cb8 --- /dev/null +++ b/src/contracts/testsuite/opcodes/chain_id.tz @@ -0,0 +1,3 @@ +parameter unit; +storage unit; +code { CHAIN_ID; DROP; CAR; NIL operation; PAIR } diff --git a/src/contracts/testsuite/opcodes/chain_id.tz.expected b/src/contracts/testsuite/opcodes/chain_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/chain_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/chain_id_store.tz b/src/contracts/testsuite/opcodes/chain_id_store.tz new file mode 100644 index 0000000000000000000000000000000000000000..11e57fd210c76ca22b4cdf912e366a70eed91669 --- /dev/null +++ b/src/contracts/testsuite/opcodes/chain_id_store.tz @@ -0,0 +1,3 @@ +parameter unit; +storage (option chain_id); +code { DROP; CHAIN_ID; SOME; NIL operation; PAIR } diff --git a/src/contracts/testsuite/opcodes/chain_id_store.tz.expected b/src/contracts/testsuite/opcodes/chain_id_store.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/chain_id_store.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/check_signature.tz b/src/contracts/testsuite/opcodes/check_signature.tz index 1d0569cb8b7918b796f0c5cd5bc3fd71545be8b6..b5d5b284264864ad8aba341673cdfe3a3652a43d 100644 --- a/src/contracts/testsuite/opcodes/check_signature.tz +++ b/src/contracts/testsuite/opcodes/check_signature.tz @@ -1,8 +1,10 @@ parameter key; storage (pair signature string); -code { DUP; DUP; +code { + DUP; DUP; DIP{ CDR; DUP; CAR; - DIP{CDR; PACK ; BLAKE2B}; PAIR}; - CAR; DIP {UNPAIR}; CHECK_SIGNATURE; + DIP{CDR; PACK}}; + CAR; CHECK_SIGNATURE; IF {} {FAIL} ; CDR; NIL operation ; PAIR}; + diff --git a/src/contracts/testsuite/opcodes/check_signature.tz.expected b/src/contracts/testsuite/opcodes/check_signature.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/check_signature.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/compare.tz b/src/contracts/testsuite/opcodes/compare.tz new file mode 100644 index 0000000000000000000000000000000000000000..963215fb46cd625a11ee6c1d1c27cbc527a09e18 --- /dev/null +++ b/src/contracts/testsuite/opcodes/compare.tz @@ -0,0 +1,52 @@ +parameter unit; +storage unit; +code { + DROP; + + # bool + PUSH bool True; DUP; COMPARE; ASSERT_EQ; + PUSH bool False; DUP; COMPARE; ASSERT_EQ; + PUSH bool False; PUSH bool True; COMPARE; ASSERT_GT; + PUSH bool True; PUSH bool False; COMPARE; ASSERT_LT; + + # bytes + PUSH bytes 0xAABBCC; DUP; COMPARE; ASSERT_EQ; + PUSH bytes 0x; PUSH bytes 0x; COMPARE; ASSERT_EQ; + PUSH bytes 0x; PUSH bytes 0x01; COMPARE; ASSERT_GT; + PUSH bytes 0x01; PUSH bytes 0x02; COMPARE; ASSERT_GT; + PUSH bytes 0x02; PUSH bytes 0x01; COMPARE; ASSERT_LT; + + # int + PUSH int 1; DUP; COMPARE; ASSERT_EQ; + PUSH int 10; PUSH int 5; COMPARE; ASSERT_LT; + PUSH int -4; PUSH int 1923; COMPARE; ASSERT_GT; + + # nat + PUSH nat 1; DUP; COMPARE; ASSERT_EQ; + PUSH nat 10; PUSH nat 5; COMPARE; ASSERT_LT; + PUSH nat 4; PUSH nat 1923; COMPARE; ASSERT_GT; + + # key_hash + PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; DUP; COMPARE; ASSERT_EQ; + PUSH key_hash "tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv"; PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; COMPARE; ASSERT_LT; + PUSH key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx"; PUSH key_hash "tz1ddb9NMYHZi5UzPdzTZMYQQZoMub195zgv"; COMPARE; ASSERT_GT; + + # mutez + PUSH mutez 1; DUP; COMPARE; ASSERT_EQ; + PUSH mutez 10; PUSH mutez 5; COMPARE; ASSERT_LT; + PUSH mutez 4; PUSH mutez 1923; COMPARE; ASSERT_GT; + + # string + PUSH string "AABBCC"; DUP; COMPARE; ASSERT_EQ; + PUSH string ""; PUSH string ""; COMPARE; ASSERT_EQ; + PUSH string ""; PUSH string "a"; COMPARE; ASSERT_GT; + PUSH string "a"; PUSH string "b"; COMPARE; ASSERT_GT; + PUSH string "b"; PUSH string "a"; COMPARE; ASSERT_LT; + + # timestamp + PUSH timestamp "2019-09-16T08:38:05Z"; DUP; COMPARE; ASSERT_EQ; + PUSH timestamp "2017-09-16T08:38:04Z"; PUSH timestamp "2019-09-16T08:38:05Z"; COMPARE; ASSERT_GT; + PUSH timestamp "2019-09-16T08:38:05Z"; PUSH timestamp "2019-09-16T08:38:04Z"; COMPARE; ASSERT_LT; + + UNIT; NIL operation; PAIR; + } diff --git a/src/contracts/testsuite/opcodes/compare.tz.expected b/src/contracts/testsuite/opcodes/compare.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/compare.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/comparisons.tz b/src/contracts/testsuite/opcodes/comparisons.tz new file mode 100644 index 0000000000000000000000000000000000000000..c603f07339ce7bc6f62bf73c63bf7967ccf79c05 --- /dev/null +++ b/src/contracts/testsuite/opcodes/comparisons.tz @@ -0,0 +1,15 @@ +parameter (list int); +storage (list (list bool)); +code { + CAR; + + NIL (list bool); + DIP {DUP; MAP { EQ; };}; SWAP; CONS; + DIP {DUP; MAP { NEQ; };}; SWAP; CONS; + DIP {DUP; MAP { LE; };}; SWAP; CONS; + DIP {DUP; MAP { LT; };}; SWAP; CONS; + DIP {DUP; MAP { GE; };}; SWAP; CONS; + DIP {MAP { GT; };}; SWAP; CONS; + + NIL operation; PAIR; + } diff --git a/src/contracts/testsuite/opcodes/comparisons.tz.expected b/src/contracts/testsuite/opcodes/comparisons.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/comparisons.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/concat_hello.tz.expected b/src/contracts/testsuite/opcodes/concat_hello.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/concat_hello.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/concat_hello_bytes.tz b/src/contracts/testsuite/opcodes/concat_hello_bytes.tz new file mode 100644 index 0000000000000000000000000000000000000000..55f8ab7a216ba24a3dc4e21f6648cfbf0abdea29 --- /dev/null +++ b/src/contracts/testsuite/opcodes/concat_hello_bytes.tz @@ -0,0 +1,4 @@ +parameter (list bytes); +storage (list bytes); +code{ CAR; + MAP { PUSH bytes 0xFF; CONCAT }; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/concat_hello_bytes.tz.expected b/src/contracts/testsuite/opcodes/concat_hello_bytes.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/concat_hello_bytes.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/concat_list.tz.expected b/src/contracts/testsuite/opcodes/concat_list.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/concat_list.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/cons.tz b/src/contracts/testsuite/opcodes/cons.tz new file mode 100644 index 0000000000000000000000000000000000000000..5189b47c36b417dda6f3e89f31a4f653970e8fad --- /dev/null +++ b/src/contracts/testsuite/opcodes/cons.tz @@ -0,0 +1,3 @@ +parameter int; +storage (list int); +code { UNPAIR; CONS; NIL operation; PAIR; }; diff --git a/src/contracts/testsuite/opcodes/cons.tz.expected b/src/contracts/testsuite/opcodes/cons.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/cons.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/contains_all.tz.expected b/src/contracts/testsuite/opcodes/contains_all.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/contains_all.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/contract.tz b/src/contracts/testsuite/opcodes/contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..939337918d1ce883ee782fc92a20b8a9c8247aff --- /dev/null +++ b/src/contracts/testsuite/opcodes/contract.tz @@ -0,0 +1,11 @@ +parameter address; +storage unit; +code { + CAR; + CONTRACT unit; + ASSERT_SOME; + DROP; + UNIT; + NIL operation; + PAIR + }; diff --git a/src/contracts/testsuite/opcodes/contract.tz.expected b/src/contracts/testsuite/opcodes/contract.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/contract.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/create_contract.tz b/src/contracts/testsuite/opcodes/create_contract.tz new file mode 100644 index 0000000000000000000000000000000000000000..d3fb8dc617a87ea8fd9aa388bafc7f8f651a7539 --- /dev/null +++ b/src/contracts/testsuite/opcodes/create_contract.tz @@ -0,0 +1,14 @@ +parameter unit; +storage (option address); +code { DROP; + UNIT; # starting storage for contract + AMOUNT; # Push the starting balance + NONE key_hash; # No delegate + CREATE_CONTRACT # Create the contract + { parameter unit ; + storage unit ; + code + { CDR; + NIL operation; + PAIR; } }; + DIP {SOME;NIL operation};CONS ; PAIR} # Ending calling convention stuff diff --git a/src/contracts/testsuite/opcodes/create_contract.tz.expected b/src/contracts/testsuite/opcodes/create_contract.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/create_contract.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/diff_timestamps.tz.expected b/src/contracts/testsuite/opcodes/diff_timestamps.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/diff_timestamps.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dig_eq.tz b/src/contracts/testsuite/opcodes/dig_eq.tz new file mode 100644 index 0000000000000000000000000000000000000000..fff548bbf59719c498c855ccaa1de8b8283355a3 --- /dev/null +++ b/src/contracts/testsuite/opcodes/dig_eq.tz @@ -0,0 +1,14 @@ +parameter (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat (pair nat nat)))))))))))))))); +storage unit; +# this contract receives a 17-tuple, unpairs it, reverses the order, reverses it again, and pairs it and verifies that the result is the same as the original tuple. +code { CAR; + DUP; + + UNPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAIR; + DIG 0; DIG 1; DIG 2; DIG 3; DIG 4; DIG 5; DIG 6; DIG 7; DIG 8; DIG 9; DIG 10; DIG 11; DIG 12; DIG 13; DIG 14; DIG 15; DIG 16; + # PUSH nat 1; ADD; + DIG 0; DIG 1; DIG 2; DIG 3; DIG 4; DIG 5; DIG 6; DIG 7; DIG 8; DIG 9; DIG 10; DIG 11; DIG 12; DIG 13; DIG 14; DIG 15; DIG 16; + PAPAPAPAPAPAPAPAPAPAPAPAPAPAPAPAIR; + ASSERT_CMPEQ; + + UNIT; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/dig_eq.tz.expected b/src/contracts/testsuite/opcodes/dig_eq.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dig_eq.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dign.tz b/src/contracts/testsuite/opcodes/dign.tz new file mode 100644 index 0000000000000000000000000000000000000000..ec8a339dd48c3c7318c72dfbce9b562839df48e1 --- /dev/null +++ b/src/contracts/testsuite/opcodes/dign.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DIG 4 ; DIP { DROP ; DROP ; DROP ; DROP } ; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/dign.tz.expected b/src/contracts/testsuite/opcodes/dign.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dign.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dip.tz b/src/contracts/testsuite/opcodes/dip.tz new file mode 100644 index 0000000000000000000000000000000000000000..f0c32a838747fe221cbb5570ae32383f6c8fb5d0 --- /dev/null +++ b/src/contracts/testsuite/opcodes/dip.tz @@ -0,0 +1,8 @@ +parameter (pair nat nat); +storage (pair nat nat); +code{ + CAR; UNPAIR; + DUP; DIP { ADD }; + PAIR; + NIL operation; + PAIR}; diff --git a/src/contracts/testsuite/opcodes/dip.tz.expected b/src/contracts/testsuite/opcodes/dip.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dip.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dipn.tz b/src/contracts/testsuite/opcodes/dipn.tz new file mode 100644 index 0000000000000000000000000000000000000000..55d088e5518f3bff8321669c94bbd1689a00c796 --- /dev/null +++ b/src/contracts/testsuite/opcodes/dipn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DIP 5 {PUSH nat 6} ; DROP ; DROP ; DROP ; DROP ; DROP ; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/dipn.tz.expected b/src/contracts/testsuite/opcodes/dipn.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dipn.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dropn.tz b/src/contracts/testsuite/opcodes/dropn.tz new file mode 100644 index 0000000000000000000000000000000000000000..4b5379b3a3b3ee3f12d1ff9110d58b2683aa953e --- /dev/null +++ b/src/contracts/testsuite/opcodes/dropn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DROP 4 ; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/dropn.tz.expected b/src/contracts/testsuite/opcodes/dropn.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dropn.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/dugn.tz b/src/contracts/testsuite/opcodes/dugn.tz new file mode 100644 index 0000000000000000000000000000000000000000..521c052f1fcd593c2707ae9698df9992cab55367 --- /dev/null +++ b/src/contracts/testsuite/opcodes/dugn.tz @@ -0,0 +1,3 @@ +parameter (pair (pair (pair (pair nat nat) nat) nat) nat); +storage nat; +code {CAR; UNPAIR ; UNPAIR ; UNPAIR ; UNPAIR ; DUG 4 ; DROP ; DROP ; DROP ; DROP ; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/dugn.tz.expected b/src/contracts/testsuite/opcodes/dugn.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/dugn.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/ediv.tz b/src/contracts/testsuite/opcodes/ediv.tz new file mode 100644 index 0000000000000000000000000000000000000000..ee577a4dc4a0f92279b4390be89c2130afd811a0 --- /dev/null +++ b/src/contracts/testsuite/opcodes/ediv.tz @@ -0,0 +1,13 @@ +parameter (pair int int); +storage (pair (option (pair int nat)) (pair (option (pair int nat)) (pair (option (pair int nat)) (option (pair nat nat))))); +code { CAR; + # :: nat : nat : 'S -> option (pair nat nat) : 'S + DUP; UNPAIR; ABS; DIP { ABS; }; EDIV; SWAP; + # :: nat : int : 'S -> option (pair int nat) : 'S + DUP; UNPAIR; ABS; EDIV; SWAP; + # :: int : nat : 'S -> option (pair int nat) : 'S + DUP; UNPAIR; DIP { ABS; }; EDIV; SWAP; + # :: int : int : 'S -> option (pair int nat) : 'S + UNPAIR; EDIV; + PAPAPAIR; + NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/ediv.tz.expected b/src/contracts/testsuite/opcodes/ediv.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/ediv.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/ediv_mutez.tz b/src/contracts/testsuite/opcodes/ediv_mutez.tz new file mode 100644 index 0000000000000000000000000000000000000000..2df73dd4a0e3b6cdd3a2451b82f21c7751ece275 --- /dev/null +++ b/src/contracts/testsuite/opcodes/ediv_mutez.tz @@ -0,0 +1,12 @@ +parameter (pair mutez (or mutez nat)); +storage (or (option (pair nat mutez)) (option (pair mutez mutez))); +code { CAR; + UNPAIR; + SWAP; + IF_LEFT { + SWAP; EDIV; LEFT (option (pair mutez mutez)); + } + { + SWAP; EDIV; RIGHT (option (pair nat mutez)); + }; + NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/ediv_mutez.tz.expected b/src/contracts/testsuite/opcodes/ediv_mutez.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/ediv_mutez.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/empty_map.tz.expected b/src/contracts/testsuite/opcodes/empty_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/empty_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/exec_concat.tz.expected b/src/contracts/testsuite/opcodes/exec_concat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/exec_concat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/first.tz.expected b/src/contracts/testsuite/opcodes/first.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/first.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/get_big_map_value.tz b/src/contracts/testsuite/opcodes/get_big_map_value.tz new file mode 100644 index 0000000000000000000000000000000000000000..4ca52343d45afabdfa0b19671d45bbf74b642de2 --- /dev/null +++ b/src/contracts/testsuite/opcodes/get_big_map_value.tz @@ -0,0 +1,6 @@ +parameter string; +storage (pair (big_map string string) (option string)); +# retrieves the values stored in the big_map on the left side of the +# pair at the key denoted by the parameter and puts it in the right +# hand side of the storage +code {DUP; CAR; DIP{CDAR; DUP}; GET; SWAP; PAIR; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/get_big_map_value.tz.expected b/src/contracts/testsuite/opcodes/get_big_map_value.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/get_big_map_value.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/get_map_value.tz.expected b/src/contracts/testsuite/opcodes/get_map_value.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/get_map_value.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/hash_consistency_checker.tz.expected b/src/contracts/testsuite/opcodes/hash_consistency_checker.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/hash_consistency_checker.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/hash_key.tz.expected b/src/contracts/testsuite/opcodes/hash_key.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/hash_key.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/hash_string.tz.expected b/src/contracts/testsuite/opcodes/hash_string.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/hash_string.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/if.tz.expected b/src/contracts/testsuite/opcodes/if.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/if.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/if_some.tz.expected b/src/contracts/testsuite/opcodes/if_some.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/if_some.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/int.tz b/src/contracts/testsuite/opcodes/int.tz new file mode 100644 index 0000000000000000000000000000000000000000..3f199881392ae45abe9ae7332c5b63ba6b735b36 --- /dev/null +++ b/src/contracts/testsuite/opcodes/int.tz @@ -0,0 +1,5 @@ +parameter nat; +storage (option int); +# this contract takes a natural number as parameter, converts it to an +# integer and stores it. +code { CAR; INT; SOME; NIL operation; PAIR }; diff --git a/src/contracts/testsuite/opcodes/int.tz.expected b/src/contracts/testsuite/opcodes/int.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/int.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/left_right.tz.expected b/src/contracts/testsuite/opcodes/left_right.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/left_right.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_concat.tz.expected b/src/contracts/testsuite/opcodes/list_concat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_concat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_concat_bytes.tz.expected b/src/contracts/testsuite/opcodes/list_concat_bytes.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_concat_bytes.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_id.tz.expected b/src/contracts/testsuite/opcodes/list_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_id_map.tz.expected b/src/contracts/testsuite/opcodes/list_id_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_id_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_iter.tz.expected b/src/contracts/testsuite/opcodes/list_iter.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_iter.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_map_block.tz.expected b/src/contracts/testsuite/opcodes/list_map_block.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_map_block.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/list_size.tz b/src/contracts/testsuite/opcodes/list_size.tz new file mode 100644 index 0000000000000000000000000000000000000000..6ced12799187fa76705a31e3f07bb9dc7c493d6b --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_size.tz @@ -0,0 +1,3 @@ +parameter (list int); +storage nat; +code {CAR; SIZE; NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/list_size.tz.expected b/src/contracts/testsuite/opcodes/list_size.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/list_size.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/loop_left.tz.expected b/src/contracts/testsuite/opcodes/loop_left.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/loop_left.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_car.tz.expected b/src/contracts/testsuite/opcodes/map_car.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_car.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_id.tz.expected b/src/contracts/testsuite/opcodes/map_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_iter.tz.expected b/src/contracts/testsuite/opcodes/map_iter.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_iter.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_map.tz b/src/contracts/testsuite/opcodes/map_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..4acbd63c32c4d5409e051c6c1eed5703c19c9a10 --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_map.tz @@ -0,0 +1,8 @@ +parameter nat; +storage (map string nat); +# this contract adds the value passed by parameter to each entry in +# the stored map. +code { UNPAIR; SWAP; + MAP { CDR; DIP {DUP}; ADD; }; + DIP { DROP; }; + NIL operation; PAIR; } diff --git a/src/contracts/testsuite/opcodes/map_map.tz.expected b/src/contracts/testsuite/opcodes/map_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_map_sideeffect.tz b/src/contracts/testsuite/opcodes/map_map_sideeffect.tz new file mode 100644 index 0000000000000000000000000000000000000000..960b02a553ceb8b4d42a2631829df3725c538def --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_map_sideeffect.tz @@ -0,0 +1,12 @@ +parameter nat; +storage (pair (map string nat) nat); +# this contract adds the value passed by parameter to each entry in +# the stored map, and it sets the second component of the pair to the +# sum of the map's elements +code { UNPAIR; SWAP; CAR; + DIP 2 { PUSH @sum nat 0; }; + MAP { CDR; DIP {DUP}; ADD; + DUP; DUG 2; DIP 2 { ADD @sum }; + }; + DIP { DROP; }; PAIR; + NIL operation; PAIR; } diff --git a/src/contracts/testsuite/opcodes/map_map_sideeffect.tz.expected b/src/contracts/testsuite/opcodes/map_map_sideeffect.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_map_sideeffect.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_mem_nat.tz b/src/contracts/testsuite/opcodes/map_mem_nat.tz new file mode 100644 index 0000000000000000000000000000000000000000..0c245d7e0a652d8430d71d47a1511e6a0d9c874f --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_mem_nat.tz @@ -0,0 +1,7 @@ +parameter nat; +storage (pair (map nat nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/contracts/testsuite/opcodes/map_mem_nat.tz.expected b/src/contracts/testsuite/opcodes/map_mem_nat.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_mem_nat.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_mem_string.tz b/src/contracts/testsuite/opcodes/map_mem_string.tz new file mode 100644 index 0000000000000000000000000000000000000000..3fa5cd5b579f534b9df0b33d5d46d525b56fbbe8 --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_mem_string.tz @@ -0,0 +1,7 @@ +parameter string; +storage (pair (map string nat) (option bool)) ; +# stores (map, Some flag) where flag = parameter is a member of +# the map in first component of storage +code { UNPAIR; + DIP { CAR; DUP }; + MEM; SOME; SWAP; PAIR; NIL operation; PAIR;} diff --git a/src/contracts/testsuite/opcodes/map_mem_string.tz.expected b/src/contracts/testsuite/opcodes/map_mem_string.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_mem_string.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/map_size.tz.expected b/src/contracts/testsuite/opcodes/map_size.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/map_size.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/mul.tz b/src/contracts/testsuite/opcodes/mul.tz new file mode 100644 index 0000000000000000000000000000000000000000..8432394b526d75ee295a4c79d134cc85525cb2ad --- /dev/null +++ b/src/contracts/testsuite/opcodes/mul.tz @@ -0,0 +1,48 @@ +parameter unit ; +storage unit ; +code { CAR ; + DROP ; + # tez-nat, no overflow + PUSH nat 7987 ; + PUSH mutez 10 ; + MUL ; + PUSH mutez 79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-tez, no overflow + PUSH mutez 10 ; + PUSH nat 7987 ; + MUL ; + PUSH mutez 79870 ; + COMPARE ; + ASSERT_EQ ; + # int-int, no overflow + PUSH int 10 ; + PUSH int -7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # int-nat, no overflow + PUSH nat 10 ; + PUSH int -7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-int, no overflow + PUSH int -10 ; + PUSH nat 7987 ; + MUL ; + PUSH int -79870 ; + COMPARE ; + ASSERT_EQ ; + # nat-nat, no overflow + PUSH nat 10 ; + PUSH nat 7987 ; + MUL ; + PUSH nat 79870 ; + COMPARE ; + ASSERT_EQ ; + + UNIT ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/mul.tz.expected b/src/contracts/testsuite/opcodes/mul.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/mul.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/mul_overflow.tz b/src/contracts/testsuite/opcodes/mul_overflow.tz new file mode 100644 index 0000000000000000000000000000000000000000..5d2b3a3dcff20b81817c52bd99a8738c12120f3f --- /dev/null +++ b/src/contracts/testsuite/opcodes/mul_overflow.tz @@ -0,0 +1,18 @@ +parameter (or unit unit) ; +storage unit ; +code { CAR ; + IF_LEFT + { + PUSH nat 922337203685477580700 ; + PUSH mutez 10 ; + MUL ; # FAILURE + DROP + } + { + PUSH mutez 10 ; + PUSH nat 922337203685477580700 ; + MUL ; # FAILURE + DROP + } ; + + NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/mul_overflow.tz.expected b/src/contracts/testsuite/opcodes/mul_overflow.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/mul_overflow.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/neg.tz b/src/contracts/testsuite/opcodes/neg.tz new file mode 100644 index 0000000000000000000000000000000000000000..9cedf765f1b2ef0c79a102b505037a9cb0c591b7 --- /dev/null +++ b/src/contracts/testsuite/opcodes/neg.tz @@ -0,0 +1,8 @@ +parameter (or int nat); +storage int; +code { + CAR; + IF_LEFT {NEG} {NEG}; + NIL operation; + PAIR + } diff --git a/src/contracts/testsuite/opcodes/neg.tz.expected b/src/contracts/testsuite/opcodes/neg.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/neg.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/none.tz b/src/contracts/testsuite/opcodes/none.tz new file mode 100644 index 0000000000000000000000000000000000000000..473a288b492662a3c80c9ff127a9a31bfb95a760 --- /dev/null +++ b/src/contracts/testsuite/opcodes/none.tz @@ -0,0 +1,3 @@ +parameter unit; +storage (option nat); +code { DROP; NONE nat; NIL operation; PAIR; }; diff --git a/src/contracts/testsuite/opcodes/none.tz.expected b/src/contracts/testsuite/opcodes/none.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/none.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/noop.tz.expected b/src/contracts/testsuite/opcodes/noop.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/noop.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/not.tz.expected b/src/contracts/testsuite/opcodes/not.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/not.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/not_binary.tz b/src/contracts/testsuite/opcodes/not_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..c1e0f97979d73983ff363a12f66ff0c1df94aa22 --- /dev/null +++ b/src/contracts/testsuite/opcodes/not_binary.tz @@ -0,0 +1,12 @@ +parameter (or int nat); +storage (option int); +code { CAR; + IF_LEFT + { + NOT; + } + { + NOT; + } ; + SOME; NIL operation ; PAIR + } diff --git a/src/contracts/testsuite/opcodes/not_binary.tz.expected b/src/contracts/testsuite/opcodes/not_binary.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/not_binary.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/or.tz.expected b/src/contracts/testsuite/opcodes/or.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/or.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/or_binary.tz b/src/contracts/testsuite/opcodes/or_binary.tz new file mode 100644 index 0000000000000000000000000000000000000000..a31f109827efa3a00b776eb1fa473e1a6800bbe9 --- /dev/null +++ b/src/contracts/testsuite/opcodes/or_binary.tz @@ -0,0 +1,9 @@ +parameter (pair nat nat); +storage (option nat); +# This contract takes a pair of natural numbers as argument and +# stores the result of their binary OR. +code { CAR; + UNPAIR; + OR; + SOME; NIL operation; PAIR + } diff --git a/src/contracts/testsuite/opcodes/or_binary.tz.expected b/src/contracts/testsuite/opcodes/or_binary.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/or_binary.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/packunpack.tz.expected b/src/contracts/testsuite/opcodes/packunpack.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/packunpack.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/packunpack_rev.tz b/src/contracts/testsuite/opcodes/packunpack_rev.tz new file mode 100644 index 0000000000000000000000000000000000000000..86871a5c6287d6ee851ba63a0f41f3174524a258 --- /dev/null +++ b/src/contracts/testsuite/opcodes/packunpack_rev.tz @@ -0,0 +1,41 @@ +parameter (pair + int + (pair + nat + (pair + string + (pair bytes (pair mutez (pair bool (pair key_hash (pair timestamp address)))))))); +storage unit ; +code { CAR; + # Check the int + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK int; ASSERT_SOME; ASSERT_CMPEQ; + # Check the nat + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK nat; ASSERT_SOME; ASSERT_CMPEQ; + # Check the string + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK string; ASSERT_SOME; ASSERT_CMPEQ; + # Check the bytes + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK bytes; ASSERT_SOME; ASSERT_CMPEQ; + # Check the mutez + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK mutez; ASSERT_SOME; ASSERT_CMPEQ; + # Check the bool + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK bool; ASSERT_SOME; ASSERT_CMPEQ; + # Check the key_hash + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK key_hash; ASSERT_SOME; ASSERT_CMPEQ; + # Check the timestamp + DUP; CAR; DIP { UNPAIR; }; PACK; UNPACK timestamp; ASSERT_SOME; ASSERT_CMPEQ; + # Check the address + DUP; PACK; UNPACK address; ASSERT_SOME; ASSERT_CMPEQ; + + # Assert failure modes of unpack + PUSH int 0; PACK; UNPACK nat; ASSERT_SOME; DROP; + PUSH int -1; PACK; UNPACK nat; ASSERT_NONE; + + # Try deserializing invalid byte sequence (no magic number) + PUSH bytes 0x; UNPACK nat; ASSERT_NONE; + PUSH bytes 0x04; UNPACK nat; ASSERT_NONE; + + # Assert failure for byte sequences that do not correspond to + # any micheline value + PUSH bytes 0x05; UNPACK nat; ASSERT_NONE; + + UNIT ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/packunpack_rev.tz.expected b/src/contracts/testsuite/opcodes/packunpack_rev.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/packunpack_rev.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz b/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz new file mode 100644 index 0000000000000000000000000000000000000000..5e32b8a6f6aa03f1c4cce9700e4634b0f298d21c --- /dev/null +++ b/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz @@ -0,0 +1,31 @@ +parameter (pair key (pair unit (pair signature (pair (option signature) (pair (list unit) (pair (set bool) (pair (pair int int) (pair (or key_hash timestamp) (pair (map int string) (lambda string bytes)))))))))); +storage unit ; +# for each uncomparable type t (we take an arbitrary parameter for +# parametric data-types e.g. pair, list), +# that is packable (which excludes big_map, operation, and contract) +# this contract receives a parameter v_t. +# it verifies that pack v_t == pack (unpack (pack v_t)) +code { CAR; + # packable uncomparable types + # checking: key + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK key; ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: unit + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK unit; ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: signature + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (signature); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: option signature + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (option signature); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: list unit + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (list unit); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: set bool + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (set bool); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: pair int int + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (pair int int); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: or key_hash timestamp + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (or key_hash timestamp); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: map int string + DUP; CAR; DIP { UNPAIR; }; PACK; DIP { PACK; UNPACK (map int string); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + # checking: lambda string bytes + DUP; PACK; DIP { PACK; UNPACK (lambda string bytes); ASSERT_SOME; PACK; }; ASSERT_CMPEQ; + + UNIT ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz.expected b/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/packunpack_rev_cty.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/pair_id.tz.expected b/src/contracts/testsuite/opcodes/pair_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/pair_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/pexec.tz b/src/contracts/testsuite/opcodes/pexec.tz new file mode 100644 index 0000000000000000000000000000000000000000..eab0c71b4f59d31213510ca84f01e59c58be61bb --- /dev/null +++ b/src/contracts/testsuite/opcodes/pexec.tz @@ -0,0 +1,6 @@ +parameter nat; +storage nat; +code { + LAMBDA (pair nat nat) nat + {UNPAIR ; ADD}; + SWAP; UNPAIR ; DIP { APPLY } ; EXEC ; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/pexec.tz.expected b/src/contracts/testsuite/opcodes/pexec.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/pexec.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/pexec_2.tz b/src/contracts/testsuite/opcodes/pexec_2.tz new file mode 100644 index 0000000000000000000000000000000000000000..d64f7442f50e1a70e0f8e7a5b19d4e3518c6ab84 --- /dev/null +++ b/src/contracts/testsuite/opcodes/pexec_2.tz @@ -0,0 +1,11 @@ +parameter int; +storage (list int); +code { + UNPAIR @p @s ; # p :: s + LAMBDA (pair int (pair int int)) int + { UNPAIR ; DIP { UNPAIR } ; ADD ; MUL }; # l :: p :: s + SWAP ; APPLY ; # l :: s + PUSH int 3 ; APPLY ; # l :: s + SWAP ; MAP { DIP { DUP } ; EXEC } ; # s :: l + DIP { DROP } ; # s + NIL operation; PAIR }; diff --git a/src/contracts/testsuite/opcodes/pexec_2.tz.expected b/src/contracts/testsuite/opcodes/pexec_2.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/pexec_2.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/proxy.tz b/src/contracts/testsuite/opcodes/proxy.tz new file mode 100644 index 0000000000000000000000000000000000000000..a9f17836e3c0566d0e6b0f95dde3938b1221990b --- /dev/null +++ b/src/contracts/testsuite/opcodes/proxy.tz @@ -0,0 +1,13 @@ +/* This proxy contract transfers the recieved amount to the contract given as parameter. + It is used to test the SOURCE and SENDER opcodes; see source.tz and sender.tz. */ +parameter (contract unit) ; +storage unit ; +code{ + UNPAIR; + AMOUNT ; + UNIT ; + TRANSFER_TOKENS; + DIP {NIL operation} ; + CONS; + PAIR + } \ No newline at end of file diff --git a/src/contracts/testsuite/opcodes/proxy.tz.expected b/src/contracts/testsuite/opcodes/proxy.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/proxy.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/ret_int.tz.expected b/src/contracts/testsuite/opcodes/ret_int.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/ret_int.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/reverse.tz.expected b/src/contracts/testsuite/opcodes/reverse.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/reverse.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/reverse_loop.tz.expected b/src/contracts/testsuite/opcodes/reverse_loop.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/reverse_loop.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/self.tz b/src/contracts/testsuite/opcodes/self.tz index 728cd5f1dbdb671093a30b1d0783f4a60b30e31f..d96457fd1331035930298a1fdbeafd81b2840d29 100644 --- a/src/contracts/testsuite/opcodes/self.tz +++ b/src/contracts/testsuite/opcodes/self.tz @@ -1,3 +1,3 @@ parameter unit ; -storage (contract unit) ; -code { DROP ; SELF ; NIL operation ; PAIR } +storage address ; +code { DROP ; SELF ; ADDRESS ; NIL operation ; PAIR } diff --git a/src/contracts/testsuite/opcodes/self.tz.expected b/src/contracts/testsuite/opcodes/self.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/self.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz b/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz new file mode 100644 index 0000000000000000000000000000000000000000..47f848c0d5a15ad00189075b19334c2021a4a9d4 --- /dev/null +++ b/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz @@ -0,0 +1,19 @@ +parameter (or (or (nat %A) (bool %B)) (or %maybe_C (unit %default) (string %C))); +storage unit; +code { + DROP; + SELF; DROP; + # Refers to entrypoint A of the current contract. + SELF %A; DROP; + # Refers to the default entry of the current contract + SELF %default; PACK; + # "SELF" w/o annotation also refers to the default + # entry of the current contract. Internally, they are equal. + SELF; PACK; ASSERT_CMPEQ; + # The following instruction would not typecheck: + # SELF %D, + # since there is no entrypoint D. + UNIT; + NIL operation; + PAIR; + } diff --git a/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz.expected b/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/self_with_default_entrypoint.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/self_with_entrypoint.tz b/src/contracts/testsuite/opcodes/self_with_entrypoint.tz new file mode 100644 index 0000000000000000000000000000000000000000..bf9cd8d1685117021caff01647caf3e0944d6314 --- /dev/null +++ b/src/contracts/testsuite/opcodes/self_with_entrypoint.tz @@ -0,0 +1,26 @@ +parameter (or (or (nat %A) (bool %B)) (or %maybe_C (unit %Z) (string %C))); +storage unit; +code { + DROP; + # Refers to entrypoint A of the current contract. + SELF %A; PACK @Apacked; + # Refers to the default entry of the current contract + SELF %default; PACK @defpacked; DUP; DIP { SWAP }; ASSERT_CMPNEQ; + # "SELF" w/o annotation also refers to the default + # entry of the current contract + SELF; PACK @selfpacked; ASSERT_CMPEQ; + + # Verify the types of the different entrypoints. CAST is noop + # if its argument is convertible with the type of the top of + # the stack. is conver + SELF %A; CAST (contract nat); DROP; + SELF %B; CAST (contract bool); DROP; + SELF %maybe_C; CAST (contract (or (unit) (string))); DROP; + SELF %Z; CAST (contract unit); DROP; + SELF; CAST (contract (or (or (nat %A) (bool %B)) (or %maybe_C (unit %Z) (string %C)))); DROP; + SELF %default; CAST (contract (or (or (nat %A) (bool %B)) (or %maybe_C (unit %Z) (string %C)))); DROP; + + UNIT; + NIL operation; + PAIR; + } diff --git a/src/contracts/testsuite/opcodes/self_with_entrypoint.tz.expected b/src/contracts/testsuite/opcodes/self_with_entrypoint.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/self_with_entrypoint.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/sender.tz b/src/contracts/testsuite/opcodes/sender.tz new file mode 100644 index 0000000000000000000000000000000000000000..fb174179aca53f366f19723e6df11924d597f26a --- /dev/null +++ b/src/contracts/testsuite/opcodes/sender.tz @@ -0,0 +1,8 @@ +parameter unit ; +storage address ; +code{ + DROP ; + SENDER; + NIL operation ; + PAIR + } diff --git a/src/contracts/testsuite/opcodes/sender.tz.expected b/src/contracts/testsuite/opcodes/sender.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/sender.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_car.tz.expected b/src/contracts/testsuite/opcodes/set_car.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_car.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_cdr.tz.expected b/src/contracts/testsuite/opcodes/set_cdr.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_cdr.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_delegate.tz b/src/contracts/testsuite/opcodes/set_delegate.tz new file mode 100644 index 0000000000000000000000000000000000000000..a7e051e50494a6c87e9e020ccf7500bc45ffbc60 --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_delegate.tz @@ -0,0 +1,9 @@ +parameter (option key_hash); +storage unit; +code { + UNPAIR; + SET_DELEGATE; + DIP {NIL operation}; + CONS; + PAIR + } diff --git a/src/contracts/testsuite/opcodes/set_delegate.tz.expected b/src/contracts/testsuite/opcodes/set_delegate.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_delegate.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_id.tz.expected b/src/contracts/testsuite/opcodes/set_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_iter.tz.expected b/src/contracts/testsuite/opcodes/set_iter.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_iter.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_member.tz.expected b/src/contracts/testsuite/opcodes/set_member.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_member.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/set_size.tz.expected b/src/contracts/testsuite/opcodes/set_size.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/set_size.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/shifts.tz b/src/contracts/testsuite/opcodes/shifts.tz new file mode 100644 index 0000000000000000000000000000000000000000..71964750c0b8070272f0039332cca69b02219c45 --- /dev/null +++ b/src/contracts/testsuite/opcodes/shifts.tz @@ -0,0 +1,18 @@ +parameter (or (pair nat nat) (pair nat nat)); +storage (option nat); +# this contract takes either (Left a b) and stores (a << b) +# or (Right a b) and stores (a >> b). +# i.e., in the first case, the first component shifted to the left by +# the second, and the second case, component shifted to the right by +# the second. +code { CAR; + IF_LEFT { + UNPAIR; LSL; + } + { + UNPAIR; LSR; + }; + SOME; + NIL operation; + PAIR; + }; diff --git a/src/contracts/testsuite/opcodes/shifts.tz.expected b/src/contracts/testsuite/opcodes/shifts.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/shifts.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/slice.tz b/src/contracts/testsuite/opcodes/slice.tz new file mode 100644 index 0000000000000000000000000000000000000000..3461bb5533d1cb3d52b98575474431cb4bc38588 --- /dev/null +++ b/src/contracts/testsuite/opcodes/slice.tz @@ -0,0 +1,5 @@ +parameter (pair nat nat); +storage (option string); +code { UNPAIR; SWAP; + IF_SOME {SWAP; UNPAIR; SLICE;} {DROP; NONE string;}; + NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/slice.tz.expected b/src/contracts/testsuite/opcodes/slice.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/slice.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/slice_bytes.tz b/src/contracts/testsuite/opcodes/slice_bytes.tz new file mode 100644 index 0000000000000000000000000000000000000000..c0f60f358765de3ce16d2bec7b32e7f1f51b7454 --- /dev/null +++ b/src/contracts/testsuite/opcodes/slice_bytes.tz @@ -0,0 +1,5 @@ +parameter (pair nat nat); +storage (option bytes); +code { UNPAIR; SWAP; + IF_SOME {SWAP; UNPAIR; SLICE;} {DROP; NONE bytes;}; + NIL operation; PAIR} diff --git a/src/contracts/testsuite/opcodes/slice_bytes.tz.expected b/src/contracts/testsuite/opcodes/slice_bytes.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/slice_bytes.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/slices.tz.expected b/src/contracts/testsuite/opcodes/slices.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/slices.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/source.tz b/src/contracts/testsuite/opcodes/source.tz new file mode 100644 index 0000000000000000000000000000000000000000..fc3c642027d3b9d0985dc0a97fdfdf7c097d0b35 --- /dev/null +++ b/src/contracts/testsuite/opcodes/source.tz @@ -0,0 +1,10 @@ +parameter unit ; + +storage address ; + +code{ + DROP ; + SOURCE; + NIL operation ; + PAIR + } \ No newline at end of file diff --git a/src/contracts/testsuite/opcodes/source.tz.expected b/src/contracts/testsuite/opcodes/source.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/source.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/split_bytes.tz.expected b/src/contracts/testsuite/opcodes/split_bytes.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/split_bytes.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/split_string.tz.expected b/src/contracts/testsuite/opcodes/split_string.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/split_string.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/steps_to_quota.tz b/src/contracts/testsuite/opcodes/steps_to_quota.tz deleted file mode 100644 index 4981864be9b173608628be5894620b526d674edb..0000000000000000000000000000000000000000 --- a/src/contracts/testsuite/opcodes/steps_to_quota.tz +++ /dev/null @@ -1,3 +0,0 @@ -parameter unit; -storage nat; -code {DROP; STEPS_TO_QUOTA; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/store_input.tz.expected b/src/contracts/testsuite/opcodes/store_input.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/store_input.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/store_now.tz.expected b/src/contracts/testsuite/opcodes/store_now.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/store_now.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/str_id.tz.expected b/src/contracts/testsuite/opcodes/str_id.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/str_id.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/sub_timestamp_delta.tz.expected b/src/contracts/testsuite/opcodes/sub_timestamp_delta.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/sub_timestamp_delta.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/subset.tz.expected b/src/contracts/testsuite/opcodes/subset.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/subset.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/tez_add_sub.tz.expected b/src/contracts/testsuite/opcodes/tez_add_sub.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/tez_add_sub.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/transfer_amount.tz.expected b/src/contracts/testsuite/opcodes/transfer_amount.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/transfer_amount.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/transfer_tokens.tz.expected b/src/contracts/testsuite/opcodes/transfer_tokens.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/transfer_tokens.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/update_big_map.tz b/src/contracts/testsuite/opcodes/update_big_map.tz new file mode 100644 index 0000000000000000000000000000000000000000..c403975a38fb1d0570b61a2c1fa90668a16f6b80 --- /dev/null +++ b/src/contracts/testsuite/opcodes/update_big_map.tz @@ -0,0 +1,6 @@ +storage (pair (big_map string string) unit); +parameter (map string (option string)); +# this contract the stored big_map according to the map taken in parameter +code { UNPAPAIR; + ITER { UNPAIR; UPDATE; } ; + PAIR; NIL operation; PAIR}; diff --git a/src/contracts/testsuite/opcodes/update_big_map.tz.expected b/src/contracts/testsuite/opcodes/update_big_map.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/update_big_map.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts/testsuite/opcodes/xor.tz b/src/contracts/testsuite/opcodes/xor.tz index ab8dcf57d086d72d07366466534908de2092a394..557eaa642b9a2a8b53857ed7ef529e3fefc58d23 100644 --- a/src/contracts/testsuite/opcodes/xor.tz +++ b/src/contracts/testsuite/opcodes/xor.tz @@ -1,3 +1,13 @@ -parameter (pair bool bool); -storage (option bool); -code {CAR; DUP; CAR; DIP{CDR}; XOR; SOME; NIL operation ; PAIR}; +parameter (or (pair bool bool) (pair nat nat)); +storage (option (or bool nat)); +code { + CAR; + IF_LEFT + { + UNPAIR; XOR; LEFT nat + } + { + UNPAIR; XOR; RIGHT bool + } ; + SOME; NIL operation ; PAIR + } diff --git a/src/contracts/testsuite/opcodes/xor.tz.expected b/src/contracts/testsuite/opcodes/xor.tz.expected new file mode 100644 index 0000000000000000000000000000000000000000..aa765d66f3f392af6193cbc6c057d40754bf2aba --- /dev/null +++ b/src/contracts/testsuite/opcodes/xor.tz.expected @@ -0,0 +1,5 @@ +Lexing: OK +Parsing: OK +Expansion: OK +Type checking: OK + diff --git a/src/contracts_coq/boomerang.v b/src/contracts_coq/boomerang.v index 347f7c2da96effc5dec692629459f1395e740e2a..c86c35f8c4a930ce6567447995704a5eda73d551 100644 --- a/src/contracts_coq/boomerang.v +++ b/src/contracts_coq/boomerang.v @@ -31,31 +31,27 @@ Require List. Definition parameter_ty := unit. Definition storage_ty := unit. -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. +Module boomerang(C:ContractContext). +Module semantics := Semantics C. Import semantics. -Module boomerang(C:ContractContext)(E:Env ST C). -Module semantics := Semantics ST C E. Import semantics. - -Definition boomerang : full_contract _ ST.self_type storage_ty := - ( - CDR ;; - NIL operation ;; - AMOUNT;; - PUSH mutez (0 ~mutez);; - IFCMPEQ NOOP - ( - SOURCE ;; - CONTRACT unit ;; - ASSERT_SOME ;; - AMOUNT ;; - UNIT ;; - TRANSFER_TOKENS ;; - CONS - );; - PAIR - ). +Definition boomerang : full_contract _ parameter_ty None storage_ty := + { + CDR; + NIL operation; + AMOUNT; + PUSH mutez (0 ~mutez); + IFCMPEQ {} + { + SOURCE ; + CONTRACT None unit ; + ASSERT_SOME ; + AMOUNT ; + UNIT ; + TRANSFER_TOKENS ; + CONS + }; + PAIR + }. Lemma eqb_eq a c1 c2 : BinInt.Z.eqb (comparison_to_int (compare a c1 c2)) Z0 = true <-> @@ -80,28 +76,29 @@ Proof. Qed. Lemma boomerang_correct : - forall (ops : data (list operation)) (fuel : Datatypes.nat), + forall env (ops : data (list operation)) (fuel : Datatypes.nat), fuel >= 42 -> - eval env boomerang fuel ((tt, tt), tt) = Return ((ops, tt), tt) + eval_seq env boomerang fuel ((tt, tt), tt) = Return ((ops, tt), tt) <-> (amount env = (0 ~Mutez) /\ ops = nil) \/ (amount env <> (0 ~Mutez) /\ - exists ctr, contract_ env unit (source env) = Some ctr /\ + exists ctr, contract_ None unit (source env) = Some ctr /\ ops = ((transfer_tokens env unit tt (amount env) ctr) :: nil)%list). Proof. - intros ops fuel Hfuel. + intros env ops fuel Hfuel. rewrite return_precond. - unfold eval. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. + unfold eval_seq_precond. unfold ">=" in Hfuel. - do 8 (more_fuel ; simpl). + more_fuel; simpl. + more_fuel; simpl. fold (simple_compare mutez). fold (compare mutez). - case_eq ((comparison_to_int (compare mutez (0 ~Mutez) (amount env)) =? 0)%Z). + rewrite match_if_exchange. + match goal with | |- (if ?b then _ else _) <-> _ => case_eq b end. - (* true *) intro Heq. rewrite eqb_eq in Heq. - do 1 (more_fuel ; simpl). split. + intro Hops. injection Hops. @@ -115,7 +112,7 @@ Proof. - intro Hneq. rewrite eqb_neq in Hneq. do 7 (more_fuel ; simpl). - destruct (contract_ env unit (source env)). + destruct (contract_ None unit (source env)). + (* Some *) split. * intro H ; right; split. diff --git a/src/contracts_coq/deposit.v b/src/contracts_coq/deposit.v index ece69e73e4001a8dd660b72489959615d380b75e..029722a57c0337272b4b71d521e8d0118fac4110 100644 --- a/src/contracts_coq/deposit.v +++ b/src/contracts_coq/deposit.v @@ -29,57 +29,67 @@ Import error. Require List. -Definition parameter_ty := (or unit mutez). +Definition parameter_ty := (or unit None mutez None). Definition storage_ty := address. -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. +Module deposit(C:ContractContext). -Module deposit(C:ContractContext)(E:Env ST C). +Module semantics := Semantics C. Import semantics. -Module semantics := Semantics ST C E. Import semantics. +Open Scope michelson_scope. -Definition deposit : full_contract _ ST.self_type storage_ty := - ( DUP;; CAR;; DIP1 CDR;; +Definition deposit : full_contract _ parameter_ty None storage_ty := + { + DUP; CAR; DIP1 { CDR }; IF_LEFT - ( DROP1;; NIL operation ) - ( DIP1 ( DUP;; - DUP;; SENDER;; COMPARE;; EQ;; IF NOOP FAILWITH;; - CONTRACT unit;; IF_NONE FAILWITH NOOP);; - PUSH unit Unit;; TRANSFER_TOKENS;; - NIL operation;; SWAP;; CONS);; - PAIR ). + { DROP1; (NIL operation) } + { DIP1 { DUP; DUP; + SENDER; COMPARE; + EQ; IF_TRUE {} { FAILWITH }; + (CONTRACT None unit); IF_NONE { FAILWITH } {} }; + PUSH unit Unit; TRANSFER_TOKENS; + (NIL operation); SWAP; CONS }; + PAIR }. Lemma deposit_correct : - forall (input : data (or unit mutez)) storage_in + forall (env : @proto_env (Some (parameter_ty, None))) + (input : data (or unit None mutez None)) storage_in (ops : data (list operation)) storage_out (fuel : Datatypes.nat), fuel >= 42 -> - eval env deposit fuel ((input, storage_in), tt) = Return ((ops, storage_out), tt) + eval_seq env deposit fuel ((input, storage_in), tt) = Return ((ops, storage_out), tt) <-> (storage_in = storage_out /\ match input with | inl tt => ops = nil | inr am => (storage_in = sender env /\ exists c : data (contract unit), - contract_ env unit storage_in = Some c /\ + contract_ None unit storage_in = Some c /\ ops = cons (transfer_tokens env unit tt am c) nil) end). Proof. - intros input storage_in ops storage_out fuel Hfuel. + intros env input storage_in ops storage_out fuel Hfuel. rewrite return_precond. - unfold eval. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. unfold ">=" in Hfuel. + unfold eval_seq_precond. do 5 (more_fuel ; simpl). destruct input as [[]|am]. - do 2 (more_fuel ; simpl). intuition congruence. - do 11 (more_fuel ; simpl). + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (eqb_eq address). - destruct (contract_ env unit storage_in). + remember (contract_ None unit storage_in) as d. + match goal with + |- context [match ?x with | Some y => _ | None => _ end] => + remember x as d2 + end. + assert (d = d2) as Hdd2 by (subst; reflexivity). + rewrite <- Hdd2. + subst d2; clear Hdd2. + destruct d. + split. * intros (Hsend, Hops). subst storage_in. @@ -87,7 +97,12 @@ Proof. do 2 (split; [reflexivity|]). exists d; split; reflexivity. * intros (Hstorage, (Hsend, (c, (Hcd, Hops)))). - intuition congruence. + split; [symmetry; assumption|]. + subst ops. + f_equal. + injection Hcd. + intro; subst. + reflexivity. + split. * intuition. * intros (_, (_, (c, (Habs, _)))). diff --git a/src/contracts_coq/generic_multisig.v b/src/contracts_coq/generic_multisig.v index d58308f33ef859f09f634ca8ad899b62fab55658..cf1818255fbe98ebb0f9bbadd38b91ffdfe51399 100644 --- a/src/contracts_coq/generic_multisig.v +++ b/src/contracts_coq/generic_multisig.v @@ -29,81 +29,90 @@ Require Import Lia. Import error. Require List. +Module annots. + Import String. + Definition main : string := "%main". + Definition operation : string := "%operation". + Definition change_keys : string := "%change_keys". +End annots. + Definition parameter_ty := - (or unit + (or unit (Some default_entrypoint.default) (pair (pair nat (or - (lambda unit (list operation)) - (pair nat (list key)))) - (list (option signature)))). - -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. + (lambda unit (list operation)) (Some annots.operation) + (pair nat (list key)) (Some annots.change_keys))) + (list (option signature))) + (Some annots.main)). -Module generic_multisig(C:ContractContext)(E:Env ST C). +Module generic_multisig(C:ContractContext). Definition storage_ty := pair nat (pair nat (list key)). -Module semantics := Semantics ST C E. Import semantics. +Module semantics := Semantics C. Import semantics. -Definition ADD_nat {S} : instruction (Some ST.self_type) _ (nat ::: nat ::: S) (nat ::: S) := ADD. +Definition ADD_nat {S} : instruction (Some (parameter_ty, None)) _ (nat ::: nat ::: S) (nat ::: S) := ADD. -Definition multisig : full_contract _ ST.self_type storage_ty := - ( - UNPAIR ;; +Definition multisig : full_contract _ parameter_ty None storage_ty := + { + UNPAIR; IF_LEFT - ( DROP1 ;; NIL operation ;; PAIR ) - ( PUSH mutez (0 ~mutez) ;; AMOUNT ;; ASSERT_CMPEQ ;; - SWAP ;; DUP ;; DIP1 ( SWAP ) ;; + { DROP1; (NIL operation); PAIR } + { PUSH mutez (0 ~mutez); AMOUNT; ASSERT_CMPEQ; + SWAP; DUP; DIP1 { SWAP }; DIP1 - ( - UNPAIR ;; - DUP ;; SELF ;; ADDRESS ;; CHAIN_ID ;; PAIR ;; PAIR ;; PACK ;; - DIP1 ( UNPAIR ;; DIP1 SWAP ) ;; SWAP - ) ;; - - UNPAIR ;; DIP1 SWAP ;; - ASSERT_CMPEQ ;; - - DIP1 SWAP ;; UNPAIR ;; + { + UNPAIR; + DUP; SELF (self_type := parameter_ty) (self_annot := None) None I; + ADDRESS; CHAIN_ID; + PAIR; PAIR; + PACK; + DIP1 { UNPAIR; DIP1 { SWAP } }; SWAP + }; + + UNPAIR; DIP1 { SWAP }; + ASSERT_CMPEQ; + + DIP1 { SWAP }; UNPAIR; DIP1 - ( - PUSH nat (nat_constant 0);; SWAP ;; + { + PUSH nat (nat_constant 0); SWAP; ITER - ( - DIP1 SWAP ;; SWAP ;; + { + DIP1 { SWAP }; SWAP; IF_CONS - ( + { IF_SOME - ( SWAP ;; + { SWAP; DIP1 - ( - SWAP ;; DIIP ( DUUP ) ;; - ( DUUUP;; DIP1 (CHECK_SIGNATURE);; SWAP;; IF (DROP1) (FAILWITH) );; - PUSH nat (nat_constant 1) ;; ADD_nat ) ) - ( SWAP ;; DROP1 ) - ) - ( + { + SWAP; DIIP { DUUP }; + DUUUP; DIP1 { CHECK_SIGNATURE }; + SWAP; IF_TRUE { DROP1 } { FAILWITH }; + PUSH nat (nat_constant 1); ADD_nat }} + { SWAP; DROP1 } + } + { FAIL - ) ;; + }; SWAP - ) - ) ;; - ASSERT_CMPLE ;; - IF_CONS (FAIL) NOOP ;; - DROP1 ;; + } + }; + ASSERT_CMPLE; + IF_CONS { FAIL } {}; + DROP1; - DIP1 ( UNPAIR ;; PUSH nat (nat_constant 1) ;; ADD ;; PAIR) ;; + DIP1 { UNPAIR; PUSH nat (nat_constant 1); ADD; PAIR }; IF_LEFT - ( UNIT ;; EXEC ) - ( - DIP1 ( CAR ) ;; SWAP ;; PAIR ;; NIL operation - );; - PAIR ) - ). + { UNIT; EXEC } + { + DIP1 { CAR }; SWAP; + PAIR; (NIL operation) + }; + PAIR } + }. Fixpoint check_all_signatures (sigs : Datatypes.list (Datatypes.option (data signature))) (keys : Datatypes.list (data key)) @@ -125,10 +134,14 @@ Fixpoint count_signatures (sigs : Datatypes.list (Datatypes.option (data signatu | cons (Some _) sigs => (count_signatures sigs + 1)%N end. -Definition action_ty := or (lambda unit (list operation)) (pair nat (list key)). +Definition action_ty := + (or + (lambda unit (list operation)) (Some annots.operation) + (pair nat (list key)) (Some annots.change_keys)). Definition pack_ty := pair (pair chain_id address) (pair nat action_ty). Definition multisig_spec + (env : @proto_env (Some (parameter_ty, None))) (parameter : data parameter_ty) (stored_counter : N) (threshold : N) @@ -154,14 +167,13 @@ Definition multisig_spec (fun k sig => check_signature env k sig - (pack env pack_ty - ((chain_id_ env, address_ env ST.self_type (self env)), - (counter, action)))) /\ + (pack env pack_ty (chain_id_ env, address_ unit (self env None I), + (counter, action)))) /\ (count_signatures sigs >= threshold)%N /\ new_stored_counter = (1 + stored_counter)%N /\ match action with | inl (existT _ _ lam) => - match (eval (no_self env) lam fuel (tt, tt)) with + match (eval_seq (no_self env) lam fuel (tt, tt)) with | Return (operations, tt) => new_threshold = threshold /\ new_keys = keys /\ @@ -175,25 +187,29 @@ Definition multisig_spec end end. -Definition multisig_head {A} (then_ : instruction (Some ST.self_type) Datatypes.false (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) A) : - instruction _ _ (pair (pair nat action_ty) (list (option signature)) ::: pair nat (pair nat (list key)) ::: nil) A +Definition multisig_head : + instruction_seq (Some (parameter_ty, None)) Datatypes.false (pair (pair nat action_ty) (list (option signature)) ::: pair nat (pair nat (list key)) ::: nil) (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) := - PUSH mutez (0 ~mutez);; AMOUNT;; ASSERT_CMPEQ;; - SWAP ;; DUP ;; DIP1 SWAP ;; - DIP1 - ( - UNPAIR ;; - DUP ;; SELF ;; ADDRESS ;; CHAIN_ID ;; PAIR ;; PAIR ;; PACK ;; - DIP1 ( UNPAIR ;; DIP1 SWAP ) ;; SWAP - ) ;; - - UNPAIR ;; DIP1 SWAP ;; - ASSERT_CMPEQ ;; - - DIP1 SWAP ;; UNPAIR ;; then_. + { + PUSH mutez (0 ~mutez); AMOUNT; ASSERT_CMPEQ; + SWAP; DUP; DIP1 { SWAP }; + DIP1 + { + UNPAIR; + DUP; SELF (self_type := parameter_ty) (self_annot := None) None I ; + ADDRESS; CHAIN_ID; + PAIR; PAIR; + PACK; + DIP1 { UNPAIR; DIP1 { SWAP }}; SWAP + }; + + UNPAIR; DIP1 { SWAP }; + ASSERT_CMPEQ; + + DIP1 { SWAP }; UNPAIR }. Definition multisig_head_spec - A + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) @@ -201,98 +217,87 @@ Definition multisig_head_spec (threshold : N) (keys : Datatypes.list (data key)) (fuel : Datatypes.nat) - (then_ : - instruction _ Datatypes.false - (nat ::: list key ::: list (option signature) ::: bytes ::: - action_ty ::: storage_ty ::: nil) - A) - (psi : stack A -> Prop) + (psi : stack (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) -> Prop) := let params := ((counter, action), sigs) in let storage : data storage_ty := (stored_counter, (threshold, keys)) in amount env = (0 ~Mutez) /\ counter = stored_counter /\ - semantics.eval_precond - fuel env then_ - psi - (threshold, - (keys, - (sigs, - (pack env pack_ty - ((chain_id_ env, address_ env ST.self_type (self env)), - (counter, action)), - (action, (storage, tt)))))). + psi (threshold, + (keys, + (sigs, + (pack env pack_ty + (chain_id_ env, address_ unit (self (self_ty := Some (parameter_ty, None)) env None I), (counter, action)), + (action, (storage, tt)))))). Ltac fold_eval_precond := change (@eval_precond_body (@eval_precond ?fuel)) with (@eval_precond (S fuel)). Lemma multisig_head_correct - A + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) (stored_counter : N) (threshold : N) (keys : Datatypes.list (data key)) - (then_ : - instruction _ _ - (nat ::: list key ::: list (option signature) ::: bytes ::: - action_ty ::: storage_ty ::: nil) - A) - (psi : stack A -> Prop) : + psi : let params := ((counter, action), sigs) in let storage : data storage_ty := (stored_counter, (threshold, keys)) in forall fuel, - 12 <= fuel -> - (semantics.eval_precond (12 + fuel) env (multisig_head then_) psi (params, (storage, tt))) + 5 <= fuel -> + (semantics.eval_seq_precond fuel env multisig_head psi (params, (storage, tt))) <-> - multisig_head_spec A counter action sigs stored_counter threshold keys fuel then_ psi. + multisig_head_spec env counter action sigs stored_counter threshold keys fuel psi. Proof. intros params storage fuel Hfuel. unfold multisig_head. unfold "+", params, storage, multisig_head_spec. - do 11 (more_fuel; simpl); repeat fold_eval_precond. + unfold eval_seq_precond. + repeat (more_fuel; simpl). + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (eqb_eq mutez). apply and_both. - repeat simpl. + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (eqb_eq nat). rewrite (eq_sym_iff counter stored_counter). apply and_both. - simpl. reflexivity. Qed. Definition multisig_iter_body : - instruction _ _ + instruction_seq _ _ (key ::: nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) (nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) := - (DIP1 SWAP ;; SWAP ;; - IF_CONS - ( - IF_SOME - ( SWAP ;; - DIP1 - ( - SWAP ;; DIIP ( DUUP ) ;; - ( DUUUP;; DIP1 (CHECK_SIGNATURE);; SWAP;; IF (DROP1) (FAILWITH) );; - PUSH nat (nat_constant 1) ;; ADD_nat ) ) - ( SWAP ;; DROP1 ) - ) - ( - FAIL - ) ;; - SWAP - ). - -Lemma multisig_iter_body_correct k n sigs packed + { + DIP1 { SWAP }; SWAP; + IF_CONS + { + IF_SOME + { SWAP; + DIP1 + { + SWAP; DIIP { DUUP }; + DUUUP; DIP1 { CHECK_SIGNATURE }; + SWAP; IF_TRUE { DROP1 } { FAILWITH }; + PUSH nat (nat_constant 1); ADD_nat }} + { SWAP; DROP1 } + } + { + FAIL + }; + SWAP + }. + +Lemma multisig_iter_body_correct env k n sigs packed (st : stack (action_ty ::: storage_ty ::: nil)) fuel psi : - 17 <= fuel -> - semantics.eval_precond fuel env multisig_iter_body psi (k, (n, (sigs, (packed, st)))) + 7 <= fuel -> + semantics.eval_seq_precond fuel env multisig_iter_body psi (k, (n, (sigs, (packed, st)))) <-> match sigs with | nil => false @@ -303,16 +308,18 @@ Lemma multisig_iter_body_correct k n sigs packed end. Proof. intro Hfuel. - repeat more_fuel. - simpl. + unfold eval_seq_precond. destruct sigs as [|[sig|] sigs]. - - reflexivity. - - case (check_signature env k sig packed). + - repeat (more_fuel; simpl). + reflexivity. + - repeat (more_fuel; simpl). + case (check_signature env k sig packed). + tauto. + split. * intro H; inversion H. * intros (H, _); discriminate. - - reflexivity. + - do 3 (more_fuel; simpl). + reflexivity. Qed. Definition multisig_iter : @@ -324,9 +331,16 @@ Definition multisig_iter : := ITER multisig_iter_body. -Lemma multisig_iter_correct keys n sigs packed +Lemma fold_eval_seq_precond fuel : + @eval_seq_precond_body (@semantics.eval_precond fuel) = + @semantics.eval_seq_precond fuel. +Proof. + reflexivity. +Qed. + +Lemma multisig_iter_correct env keys n sigs packed (st : stack (action_ty ::: storage_ty ::: nil)) fuel psi : - length keys * 17 + 1 <= fuel -> + length keys + 7 <= fuel -> semantics.eval_precond fuel env multisig_iter psi (keys, (n, (sigs, (packed, st)))) <-> (exists first_sigs remaining_sigs, length first_sigs = length keys /\ @@ -355,9 +369,11 @@ Proof. exact H. - simpl in Hfuel. more_fuel. - change (16 + (length keys * 17 + 1) <= fuel) in Hfuel. - assert (length keys * 17 + 1 <= fuel) as Hfuel2 by (transitivity (16 + (length keys * 17 + 1)); [repeat constructor| apply Hfuel]). + unfold multisig_iter. + remember multisig_iter_body as mib. simpl. + subst mib. + rewrite fold_eval_seq_precond. rewrite multisig_iter_body_correct. + destruct sigs as [|[sig|] sigs]. * split; [intro H; inversion H|]. @@ -370,7 +386,7 @@ Proof. discriminate. * split. -- intros (Hcheck, Hrec). - specialize (IHkeys (1 + n)%N sigs packed fuel Hfuel2). + specialize (IHkeys (1 + n)%N sigs packed fuel Hfuel). rewrite IHkeys in Hrec. destruct Hrec as (first_sigs, (remaining_sigs, (Hlen, (Happ, (Hchecks, H))))). exists (Some sig :: first_sigs)%list. @@ -396,7 +412,7 @@ Proof. destruct (check_signature env key sig packed). ** simpl in Hchecks. split; [reflexivity|]. - apply (IHkeys _ _ _ _ Hfuel2). + apply (IHkeys _ _ _ _ Hfuel). exists first_sigs; exists remaining_sigs. simpl in Hlen. apply NPeano.Nat.succ_inj in Hlen. @@ -410,7 +426,7 @@ Proof. inversion Hchecks. ++ simpl in Happ. discriminate. - * rewrite (IHkeys _ _ _ _ Hfuel2). + * rewrite (IHkeys _ _ _ _ Hfuel). split; intros (first_sigs, (remaining_sigs, (Hlen, (Happ, (Hchecks, H))))). -- exists (None :: first_sigs)%list. @@ -432,52 +448,52 @@ Proof. split; [injection Happ; auto|]. split; [exact Hchecks|]. exact H. - + transitivity (16 + (length keys * 17 + 1)). - * destruct (length keys). - -- simpl. constructor. - -- omega. - * assumption. + + omega. Qed. Definition multisig_tail : - instruction (Some ST.self_type) _ + instruction_seq (Some (parameter_ty, None)) _ (nat ::: nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) (pair (list operation) storage_ty ::: nil) := + { + ASSERT_CMPLE; + IF_CONS { FAIL } {}; + DROP1; - ASSERT_CMPLE ;; - IF_CONS (FAIL) NOOP ;; - DROP1 ;; + DIP1 { UNPAIR; PUSH nat (nat_constant 1); ADD; PAIR }; - DIP1 ( UNPAIR ;; PUSH nat (nat_constant 1) ;; ADD ;; PAIR) ;; - - IF_LEFT - ( UNIT ;; EXEC ) - ( - DIP1 ( CAR ) ;; SWAP ;; PAIR ;; NIL operation - );; - PAIR. + IF_LEFT + { UNIT; EXEC } + { + DIP1 { CAR }; SWAP; + PAIR; (NIL operation) + }; + PAIR }. Lemma multisig_split : multisig = - ( - UNPAIR ;; + { + UNPAIR; IF_LEFT - ( DROP1 ;; NIL operation ;; PAIR ) - ( multisig_head (DIP1 (PUSH nat (nat_constant 0%N);; SWAP;; multisig_iter);; multisig_tail))). + { DROP1; NIL operation; PAIR } + ( multisig_head ;;; + DIP1 { PUSH nat (nat_constant 0%N); SWAP; multisig_iter };; + multisig_tail) + }%michelson. Proof. reflexivity. Qed. Lemma multisig_tail_correct - threshold n sigs packed action counter (keys : data (list key)) psi fuel : + env threshold n sigs packed action counter (keys : data (list key)) psi fuel : 3 <= fuel -> - precond (semantics.eval env multisig_tail (10 + fuel) (threshold, (n, (sigs, (packed, (action, ((counter, (threshold, keys)), tt))))))) psi <-> + precond (semantics.eval_seq env multisig_tail (S (S fuel)) (threshold, (n, (sigs, (packed, (action, ((counter, (threshold, keys)), tt))))))) psi <-> sigs = nil /\ ((threshold <= n)%N /\ match action with | inl (existT _ _ lam) => - match eval (no_self env) lam (2 + fuel) (tt, tt) with + match eval_seq (no_self env) lam fuel (tt, tt) with | Return (operations, tt) => psi ((operations, ((1 + counter)%N, (threshold, keys))), tt) | _ => False @@ -487,10 +503,13 @@ Lemma multisig_tail_correct end). Proof. intro Hfuel. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. unfold multisig_tail. - change (10 + fuel) with (S (S (S (S (6 + fuel))))). - simpl eval_precond. + unfold eval_seq_precond. + simpl. + rewrite match_if_exchange. + more_fuel; simpl. + more_fuel; simpl. case sigs. - case_eq (BinInt.Z.leb (comparison_to_int (threshold ?= n)%N) Z0). + intro Hle. @@ -501,11 +520,12 @@ Proof. apply (and_right eq_refl). apply (and_right Hle). destruct action as [(tff, lam)|(new_threshold, new_keys)]. - * do 2 fold_eval_precond. - rewrite <- eval_precond_correct. - change (2 + fuel) with (S (S fuel)). - case (semantics.eval _ lam (S (S fuel)) (tt, tt)). - -- intro; split; intro H; inversion H. + * more_fuel; simpl. + repeat fold_eval_precond. + rewrite fold_eval_seq_precond. + rewrite <- eval_seq_precond_correct. + case (semantics.eval_seq _ lam (S (S (S fuel))) (tt, tt)). + -- intro; split; intro H; simpl in H; inversion H. -- intro s; reflexivity. * reflexivity. + intro Hle. @@ -524,6 +544,7 @@ Proof. Qed. Lemma multisig_correct + (env : @proto_env (Some (parameter_ty, None))) (params : data parameter_ty) (stored_counter : N) (threshold : N) @@ -535,16 +556,17 @@ Lemma multisig_correct (fuel : Datatypes.nat) : let storage : data storage_ty := (stored_counter, (threshold, keys)) in let new_storage : data storage_ty := (new_stored_counter, (new_threshold, new_keys)) in - 17 * length keys + 14 <= fuel -> - eval env multisig (23 + fuel) ((params, storage), tt) = Return ((returned_operations, new_storage), tt) <-> - multisig_spec params stored_counter threshold keys new_stored_counter new_threshold new_keys returned_operations fuel. + length keys + 7 <= fuel -> + eval_seq env multisig (3 + fuel) ((params, storage), tt) = Return ((returned_operations, new_storage), tt) <-> + multisig_spec env params stored_counter threshold keys new_stored_counter new_threshold new_keys returned_operations fuel. Proof. intros storage new_storage Hfuel. rewrite return_precond. rewrite multisig_split. rewrite PeanoNat.Nat.add_comm in Hfuel. subst storage. subst new_storage. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. + unfold eval_seq_precond. destruct params as [()| ((counter, action), sigs)]. - split; simpl. + intro H; injection H. intuition. @@ -552,28 +574,28 @@ Proof. reflexivity. - remember multisig_head as mh. remember multisig_iter as mi. - change (23 + fuel) with (S (S (21 + fuel))). simpl. repeat fold_eval_precond. subst mh. - unfold multisig_spec. - change (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S fuel))))))))))))))))))))) with (12 + (S (S (S (S (S (S (S (S (S fuel)))))))))). + repeat fold_eval_precond. + rewrite fold_eval_seq_precond. + rewrite eval_seq_assoc. rewrite multisig_head_correct; [|omega]. unfold multisig_head_spec. apply and_both. apply and_both_2. intro; subst counter. remember multisig_tail as mt. + unfold eval_seq_precond. simpl. - do 8 fold_eval_precond. + repeat fold_eval_precond. subst mi. - rewrite multisig_iter_correct; [|rewrite Nat.mul_comm; generalize Hfuel; simpl; lia]. + rewrite multisig_iter_correct; [| rewrite PeanoNat.Nat.add_comm; refine (NPeano.Nat.le_trans _ _ _ Hfuel _); omega]. split. + intros (first_sigs, (remaining_sigs, (Hlen, (Hsigs, (Hcheck, Heval))))). subst mt. - do 6 more_fuel. - rewrite <- eval_precond_correct in Heval. - change (S (S (S (S (S (S (S (S (S (S (S (S (S (S fuel)))))))))))))) with (10 + (4 + fuel)) in Heval. + rewrite fold_eval_seq_precond in Heval. + rewrite <- eval_seq_precond_correct in Heval. rewrite multisig_tail_correct in Heval; [|omega]. destruct Heval as (Hrs, (Hcount, Haction)). subst remaining_sigs. @@ -585,10 +607,8 @@ Proof. apply N.le_ge in Hcount. split; [assumption|]. destruct action as [(tff, lam)|(nt, nks)]. - * change (2 + (4 + fuel)) with (S (S (S (S (S (S fuel)))))) in Haction. - destruct (eval _ lam (S (S (S (S (S (S fuel)))))) (tt, tt)) as [|(ops, [])]. - -- simpl in Haction. - inversion Haction. + * destruct (eval_seq _ lam fuel (tt, tt)) as [|(ops, [])]. + -- inversion Haction. -- injection Haction; intros; subst. repeat constructor. * injection Haction; intros; subst. repeat constructor. + intros (Hlen, (Hcheck, (Hcount, Haction))). @@ -598,9 +618,8 @@ Proof. rewrite List.app_nil_r. split; [reflexivity|]. split; [assumption|]. - rewrite <- eval_precond_correct. - do 2 more_fuel. - change (S (S (S (S (S (S (S (S (S (S fuel)))))))))) with (10 + fuel). + rewrite fold_eval_seq_precond. + rewrite <- eval_seq_precond_correct. subst mt. rewrite multisig_tail_correct; [|omega]. split; [reflexivity|]. @@ -609,8 +628,7 @@ Proof. split; [assumption|]. destruct Haction as (Hcounter, Haction). destruct action as [(tff, lam)|(nt, nks)]. - * change (2 + fuel) with (S (S fuel)). - destruct (eval _ lam (S (S fuel)) (tt, tt)) as [|(ops, [])]. + * destruct (eval_seq _ lam fuel (tt, tt)) as [|(ops, [])]. -- inversion Haction. -- destruct Haction as (Ht, (Hk, Hops)); subst; reflexivity. * destruct Haction as (Ht, (Hk, Hops)); subst; reflexivity. diff --git a/src/contracts_coq/manager.v b/src/contracts_coq/manager.v index 6991ff87703510b825d4d3a0238dbbe06b5be33a..c6d788845bce272d294d9aae2429199a9fb2a2ea 100644 --- a/src/contracts_coq/manager.v +++ b/src/contracts_coq/manager.v @@ -31,45 +31,42 @@ Import error. Require List. Require Import Lia. -Definition parameter_ty := or (lambda unit (list operation)) unit. +Definition parameter_ty := or (lambda unit (list operation)) (Some "%do"%string) unit (Some "%default"%string). Definition storage_ty := key_hash. -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. - -Module manager(C:ContractContext)(E:Env ST C). - -Module semantics := Semantics ST C E. Import semantics. - -Definition manager : full_contract _ ST.self_type storage_ty := - (UNPAIR ;; - IF_LEFT - ( (* 'do' entrypoint *) - (* Assert no token was sent: *) - (* to send tokens, the default entry point should be used *) - PUSH mutez (0 ~mutez) ;; - AMOUNT ;; - ASSERT_CMPEQ ;; - (* Assert that the sender is the manager *) - DUUP ;; - IMPLICIT_ACCOUNT ;; - ADDRESS ;; - SENDER ;; - ASSERT_CMPEQ ;; - (* Execute the lambda argument *) - UNIT ;; - EXEC ;; - PAIR - ) - ( (* 'default' entrypoint *) - DROP1 ;; - NIL operation ;; - PAIR - ) - ). +Module manager(C:ContractContext). + +Module semantics := Semantics C. Import semantics. + +Definition manager : full_contract _ parameter_ty None storage_ty := + { UNPAIR; + IF_LEFT + { (* 'do' entrypoint *) + (* Assert no token was sent: *) + (* to send tokens, the default entry point should be used *) + PUSH mutez (0 ~mutez); + AMOUNT; + ASSERT_CMPEQ; + (* Assert that the sender is the manager *) + DUUP; + IMPLICIT_ACCOUNT; + ADDRESS; + SENDER; + ASSERT_CMPEQ; + (* Execute the lambda argument *) + UNIT; + EXEC; + PAIR + } + { (* 'default' entrypoint *) + DROP1 ; + NIL operation ; + PAIR + } + }. Definition manager_spec + (env : @proto_env (Some (parameter_ty, None))) (storage : data storage_ty) (param : data parameter_ty) (new_storage : data storage_ty) @@ -83,9 +80,9 @@ Definition manager_spec | inl (existT _ _ lam) => (* %do is only available to the stored manager and rejects non-null amounts*) amount env = (0 ~Mutez) /\ - sender env = address_ env unit (implicit_account env storage) /\ + sender env = address_ unit (implicit_account storage) /\ new_storage = storage /\ - eval (no_self env) lam fuel (tt, tt) = Return (returned_operations, tt) + eval_seq (no_self env) lam fuel (tt, tt) = Return (returned_operations, tt) end. Lemma eqb_eq a c1 c2 : @@ -137,37 +134,38 @@ Proof. Qed. Lemma manager_correct + (env : @proto_env (Some (parameter_ty, None))) (storage : data storage_ty) (param : data parameter_ty) (new_storage : data storage_ty) (returned_operations : data (list operation)) (fuel : Datatypes.nat) : fuel >= 42 -> - eval env manager (13 + fuel) ((param, storage), tt) = Return ((returned_operations, new_storage), tt) - <-> manager_spec storage param new_storage returned_operations fuel. + eval_seq env manager (2 + fuel) ((param, storage), tt) = Return ((returned_operations, new_storage), tt) + <-> manager_spec env storage param new_storage returned_operations fuel. Proof. intro Hfuel. - remember (13 + fuel) as fuel2. - assert (30 <= fuel2) by lia. + unfold ">=" in Hfuel. rewrite return_precond. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. + unfold eval_seq_precond. unfold manager_spec. - do 5 (more_fuel; simpl). + more_fuel; simpl. + more_fuel; simpl. destruct param as [(tff, lam)|[]]. - - do 5 (more_fuel; simpl). - simpl. + - simpl. + rewrite match_if_exchange. + more_fuel; simpl. rewrite if_false_is_and. rewrite (eqb_eq mutez). apply and_both. - do 5 (more_fuel; simpl). + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (eqb_eq address). apply and_both. - simpl in Heqfuel2. repeat rewrite fold_eval_precond. - assert (fuel = S (S fuel2)) by lia. - subst fuel. clear Hfuel. - rewrite <- eval_precond_correct. + fold (eval_seq_precond (S (S (S fuel))) (self_type := None)). + rewrite <- eval_seq_precond_correct. rewrite precond_exists. unfold precond_ex. split. diff --git a/src/contracts_coq/multisig.v b/src/contracts_coq/multisig.v index f946f13eefb7f46db491d5fd86798fe3ec3f3f9f..c79481b4dd15882c2efda633ca00c41500d12ea8 100644 --- a/src/contracts_coq/multisig.v +++ b/src/contracts_coq/multisig.v @@ -19,6 +19,7 @@ (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) +Require String. Require Import Michocoq.macros. Import syntax. Import comparable. @@ -27,8 +28,15 @@ Require Import semantics. Require Import util. Import error. Require List. +Require Import Lia. -Definition action_ty := or (pair mutez (contract unit)) (or (option key_hash) (pair nat (list key))). +Module annots. + Import String. + Definition delegate : string := "%delegate". + Definition change_keys : string := "%change_keys". +End annots. + +Definition action_ty := or (pair mutez (contract unit)) None (or (option key_hash) (Some annots.delegate) (pair nat (list key)) (Some annots.change_keys)) None. Definition parameter_ty := (pair (pair @@ -38,67 +46,74 @@ Definition parameter_ty := (pair Definition storage_ty := pair nat (pair nat (list key)). -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. - -Module multisig(C:ContractContext)(E:Env ST C). +Module multisig(C:ContractContext). -Module semantics := Semantics ST C E. Import semantics. +Module semantics := Semantics C. Import semantics. -Definition ADD_nat {S} : instruction (Some ST.self_type) _ (nat ::: nat ::: S) (nat ::: S) := ADD. +Definition ADD_nat {S} : instruction (Some (parameter_ty, None)) _ (nat ::: nat ::: S) (nat ::: S) := ADD. Definition pack_ty := pair (pair chain_id address) (pair nat action_ty). -Definition multisig : full_contract _ ST.self_type storage_ty := - ( - UNPAIR ;; SWAP ;; DUP ;; DIP1 SWAP ;; +Definition multisig : full_contract false parameter_ty None storage_ty := + { + UNPAIR; SWAP; DUP; DIP1 { SWAP}; DIP1 - ( - UNPAIR ;; - DUP ;; SELF ;; ADDRESS ;; CHAIN_ID ;; PAIR ;; PAIR ;; - PACK ;; - DIP1 ( UNPAIR ;; DIP1 SWAP ) ;; SWAP - ) ;; - - UNPAIR ;; DIP1 SWAP ;; - ASSERT_CMPEQ ;; - - DIP1 SWAP ;; UNPAIR ;; + { + UNPAIR; + DUP; SELF (self_type := parameter_ty) (self_annot := None) None I; + ADDRESS; + CHAIN_ID; + PAIR; + PAIR; + PACK; + DIP1 { UNPAIR; DIP1 { SWAP }}; + SWAP + }; + + UNPAIR; DIP1 { SWAP }; + ASSERT_CMPEQ; + + DIP1 { SWAP }; UNPAIR; DIP1 - ( - PUSH nat (nat_constant 0%N) ;; SWAP ;; + { + PUSH nat (nat_constant 0%N); + SWAP; ITER - ( - DIP1 SWAP ;; SWAP ;; + { + DIP1 { SWAP }; SWAP; IF_CONS - ( + { IF_SOME - ( SWAP ;; + { SWAP; DIP1 - ( - SWAP ;; DIIP ( DIP1 DUP ;; SWAP ) ;; - CHECK_SIGNATURE ;; ASSERT ;; - PUSH nat (nat_constant 1%N) ;; ADD_nat)) - ( SWAP ;; DROP1 ) - ) - ( + { + SWAP; + DIIP { DIP1 { DUP }; + SWAP }; + CHECK_SIGNATURE; ASSERT; + PUSH nat (nat_constant 1%N); ADD_nat}} + { SWAP; DROP1 } + } + { FAIL - ) ;; + }; SWAP - ) - ) ;; - ASSERT_CMPLE ;; - DROP1 ;; DROP1 ;; + } + }; + ASSERT_CMPLE; + DROP1; DROP1; - DIP1 ( UNPAIR ;; PUSH nat (nat_constant 1%N) ;; ADD ;; PAIR ) ;; + DIP1 { UNPAIR; PUSH nat (nat_constant 1%N); ADD; PAIR }; - NIL operation ;; SWAP ;; + NIL operation; SWAP; IF_LEFT - ( UNPAIR ;; UNIT ;; TRANSFER_TOKENS ;; CONS ) - ( IF_LEFT (SET_DELEGATE ;; CONS ) - ( DIP1 ( SWAP ;; CAR ) ;; SWAP ;; PAIR ;; SWAP )) ;; - PAIR ). + { UNPAIR; UNIT; TRANSFER_TOKENS; + CONS } + { IF_LEFT { SET_DELEGATE; CONS } + { DIP1 { SWAP; CAR }; + SWAP; PAIR; + SWAP }}; + PAIR }. Fixpoint check_all_signatures (sigs : Datatypes.list (Datatypes.option (data signature))) (keys : Datatypes.list (data key)) @@ -122,6 +137,7 @@ Fixpoint count_signatures (sigs : Datatypes.list (Datatypes.option (data signatu Definition multisig_spec + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) @@ -143,7 +159,7 @@ Definition multisig_spec (fun k sig => check_signature env k sig - (pack env pack_ty ((chain_id_ env, address_ env ST.self_type (self env)), + (pack env pack_ty ((chain_id_ env, address_ parameter_ty (self env None I)), (counter, action)))) /\ (count_signatures first_sigs >= threshold)%N /\ new_stored_counter = (1 + stored_counter)%N /\ @@ -162,26 +178,32 @@ Definition multisig_spec returned_operations = nil end. -Definition multisig_head (then_ : instruction (Some ST.self_type) Datatypes.false (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) (pair (list operation) storage_ty ::: nil)) : - instruction _ _ - (pair parameter_ty storage_ty ::: nil) - (pair (list operation) storage_ty ::: nil) +Definition multisig_head : + instruction_seq _ _ + (pair parameter_ty storage_ty ::: nil) + (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) := - UNPAIR ;; SWAP ;; DUP ;; DIP1 SWAP ;; + { + UNPAIR; SWAP; DUP; + DIP1 { SWAP }; DIP1 - ( - UNPAIR ;; - DUP ;; SELF ;; ADDRESS ;; CHAIN_ID ;; PAIR ;; PAIR ;; - PACK ;; - DIP1 ( UNPAIR ;; DIP1 SWAP ) ;; SWAP - ) ;; + { + UNPAIR; + DUP; SELF (self_type := parameter_ty) (self_annot := None) None I; + ADDRESS; CHAIN_ID; + PAIR; PAIR; + PACK; + DIP1 { UNPAIR; DIP1 { SWAP } }; + SWAP + }; - UNPAIR ;; DIP1 SWAP ;; - ASSERT_CMPEQ ;; + UNPAIR; DIP1 { SWAP }; + ASSERT_CMPEQ; - DIP1 SWAP ;; UNPAIR ;; then_. + DIP1 { SWAP }; UNPAIR}. Definition multisig_head_spec + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) @@ -189,93 +211,94 @@ Definition multisig_head_spec (threshold : N) (keys : Datatypes.list (data key)) (fuel : Datatypes.nat) - (then_ : - instruction _ Datatypes.false - (nat ::: list key ::: list (option signature) ::: bytes ::: - action_ty ::: storage_ty ::: nil) - (pair (list operation) storage_ty ::: nil)) - (psi : stack (pair (list operation) storage_ty ::: nil) -> Prop) + (psi : stack (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) -> Prop) := let params : data parameter_ty := ((counter, action), sigs) in let storage : data storage_ty := (stored_counter, (threshold, keys)) in counter = stored_counter /\ - precond - (eval env - then_ fuel - (threshold, + psi (threshold, (keys, (sigs, (pack env pack_ty - ((chain_id_ env, address_ env ST.self_type (self env)), (counter, action)), - (action, (storage, tt))))))) psi. + ((chain_id_ env, address_ parameter_ty (self env None I)), (counter, action)), + (action, (storage, tt)))))). Lemma fold_eval_precond fuel : eval_precond_body (@semantics.eval_precond fuel) = - @semantics.eval_precond (S fuel) (Some ST.self_type). + @semantics.eval_precond (S fuel) (Some (parameter_ty, None)). +Proof. + reflexivity. +Qed. + +Lemma fold_eval_seq_precond fuel : + eval_seq_precond_body (@semantics.eval_precond fuel) = + @semantics.eval_seq_precond fuel (Some (parameter_ty, None)). Proof. reflexivity. Qed. Lemma multisig_head_correct + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) (stored_counter : N) (threshold : N) (keys : Datatypes.list (data key)) - (then_ : - instruction _ _ - (nat ::: list key ::: list (option signature) ::: bytes ::: - action_ty ::: storage_ty ::: nil) - (pair (list operation) storage_ty ::: nil)) - (psi : stack (pair (list operation) storage_ty ::: nil) -> Prop) : + (psi : stack (nat ::: list key ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) -> Prop) : let params : data parameter_ty := ((counter, action), sigs) in let storage : data storage_ty := (stored_counter, (threshold, keys)) in - forall fuel, 11 <= fuel -> - (precond (eval env (multisig_head then_) (10 + fuel) ((params, storage), tt)) psi) + forall fuel, 5 <= fuel -> + eval_seq_precond fuel env multisig_head psi ((params, storage), tt) <-> - multisig_head_spec counter action sigs stored_counter threshold keys - fuel then_ psi. + multisig_head_spec env counter action sigs stored_counter threshold keys + fuel psi. Proof. intros params storage fuel Hfuel. - rewrite eval_precond_correct. unfold multisig_head. unfold "+", params, storage, multisig_head_spec. - rewrite eval_precond_correct. - repeat (more_fuel; simpl). + unfold eval_seq_precond. + do 5 (more_fuel; simpl). + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (eqb_eq nat). intuition. Qed. Definition multisig_iter_body : - instruction _ _ + instruction_seq _ _ (key ::: nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) (nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) := - (DIP1 SWAP ;; SWAP ;; - IF_CONS - ( - IF_SOME - ( SWAP ;; - DIP1 - ( - SWAP ;; DIIP ( DIP1 DUP ;; SWAP ) ;; - CHECK_SIGNATURE ;; ASSERT ;; - PUSH nat (nat_constant 1%N) ;; ADD_nat)) - ( SWAP ;; DROP1 ) - ) - ( - FAIL - ) ;; - SWAP). - -Lemma multisig_iter_body_correct k n sigs packed + { + DIP1 { SWAP }; SWAP; + IF_CONS + { + IF_SOME + { + SWAP; + DIP1 + { + SWAP; + DIIP { DIP1 { DUP }; SWAP }; + CHECK_SIGNATURE; ASSERT; + PUSH nat (nat_constant 1%N); ADD_nat + } + } + { SWAP; DROP1 } + } + { + FAIL + }; + SWAP + }. + +Lemma multisig_iter_body_correct env k n sigs packed (st : stack (action_ty ::: storage_ty ::: nil)) fuel psi : - 14 <= fuel -> - precond (eval env multisig_iter_body fuel (k, (n, (sigs, (packed, st))))) psi + 6 <= fuel -> + precond (eval_seq env multisig_iter_body fuel (k, (n, (sigs, (packed, st))))) psi <-> match sigs with | nil => false @@ -286,16 +309,15 @@ Lemma multisig_iter_body_correct k n sigs packed end. Proof. intro Hfuel. - rewrite eval_precond_correct. - repeat more_fuel. - simpl. + rewrite eval_seq_precond_correct. + unfold eval_seq_precond. + repeat (more_fuel; simpl). destruct sigs as [|[sig|] sigs]. - reflexivity. - - case (check_signature env k sig packed). - + tauto. - + split. - * intro H; inversion H. - * intros (H, _); discriminate. + - rewrite match_if_exchange. + rewrite if_false_is_and. + apply and_both. + reflexivity. - reflexivity. Qed. @@ -311,9 +333,9 @@ Definition multisig_iter : (* Executing on stack (keys, n, sigs, packed, st) returns (nb_valid_sigs + n, nb_excess_sigs, packed, st) *) (* Invariant: all_keys = verified_keys @ remaining *) -Lemma multisig_iter_correct keys n sigs packed +Lemma multisig_iter_correct env keys n sigs packed (st : stack (action_ty ::: storage_ty ::: nil)) fuel psi : - length keys * 14 + 1 <= fuel -> + length keys + 6 <= fuel -> precond (eval env multisig_iter fuel (keys, (n, (sigs, (packed, st))))) psi <-> (exists first_sigs remaining_sigs, length first_sigs = length keys /\ @@ -343,10 +365,12 @@ Proof. exact H. - simpl in Hfuel. more_fuel. - change (13 + (length keys * 14 + 1) <= fuel) in Hfuel. - assert (length keys * 14 + 1 <= fuel) as Hfuel2 by (transitivity (13 + (length keys * 14 + 1)); [repeat constructor| apply Hfuel]). + unfold multisig_iter. + remember multisig_iter_body as mib. simpl. - rewrite <- eval_precond_correct. + rewrite fold_eval_seq_precond. + rewrite <- eval_seq_precond_correct. + subst mib. rewrite multisig_iter_body_correct. + destruct sigs as [|[sig|] sigs]. * split; [intro H; inversion H|]. @@ -359,7 +383,7 @@ Proof. discriminate. * split. -- intros (Hcheck, Hrec). - specialize (IHkeys (1 + n)%N sigs packed fuel Hfuel2). + specialize (IHkeys (1 + n)%N sigs packed fuel Hfuel). rewrite IHkeys in Hrec. destruct Hrec as (first_sigs, (remaining_sigs, (Hlen, (Happ, (Hchecks, H))))). exists (Some sig :: first_sigs)%list. @@ -385,7 +409,7 @@ Proof. destruct (check_signature env key sig packed). ** simpl in Hchecks. split; [reflexivity|]. - apply (IHkeys _ _ _ _ Hfuel2). + apply (IHkeys _ _ _ _ Hfuel). exists first_sigs; exists remaining_sigs. simpl in Hlen. apply NPeano.Nat.succ_inj in Hlen. @@ -399,7 +423,7 @@ Proof. inversion Hchecks. ++ simpl in Happ. discriminate. - * rewrite (IHkeys _ _ _ _ Hfuel2). + * rewrite (IHkeys _ _ _ _ Hfuel). split; intros (first_sigs, (remaining_sigs, (Hlen, (Happ, (Hchecks, H))))). -- exists (None :: first_sigs)%list. @@ -421,40 +445,42 @@ Proof. split; [injection Happ; auto|]. split; [exact Hchecks|]. exact H. - + transitivity (13 + (length keys * 14 + 1)). - * destruct (length keys). - -- simpl. constructor. - -- simpl. repeat (apply Le.le_n_S). - apply le_0_n. - * assumption. + + lia. Qed. Definition multisig_tail : - instruction _ _ + instruction_seq _ _ (nat ::: nat ::: list (option signature) ::: bytes ::: action_ty ::: storage_ty ::: nil) (pair (list operation) storage_ty ::: nil) := - ASSERT_CMPLE ;; - DROP1 ;; DROP1 ;; + { + ASSERT_CMPLE; + DROP1; DROP1; - DIP1 ( UNPAIR ;; PUSH nat (nat_constant 1%N) ;; ADD_nat ;; PAIR ) ;; + DIP1 { UNPAIR; PUSH nat (nat_constant 1%N); ADD_nat; PAIR }; - NIL operation ;; SWAP ;; + NIL operation; SWAP; IF_LEFT - ( UNPAIR ;; UNIT ;; TRANSFER_TOKENS ;; CONS ) - ( IF_LEFT (SET_DELEGATE ;; CONS ) - ( DIP1 ( SWAP ;; CAR ) ;; SWAP ;; PAIR ;; SWAP )) ;; - PAIR. - -Lemma multisig_split : multisig = multisig_head (DIP1 (PUSH nat (nat_constant 0%N);; SWAP;; multisig_iter);; multisig_tail). + { UNPAIR; UNIT; TRANSFER_TOKENS; + CONS } + { IF_LEFT { SET_DELEGATE; CONS } + { DIP1 { SWAP; CAR }; + SWAP; PAIR; + SWAP } }; + PAIR }. + +Lemma multisig_split : multisig = + (multisig_head ;;; + DIP1 { PUSH nat (nat_constant 0%N); SWAP; multisig_iter };; + multisig_tail). Proof. reflexivity. Qed. Lemma multisig_tail_correct - threshold n sigs packed action counter keys psi fuel : - 13 <= fuel -> - precond (eval env multisig_tail fuel (threshold, (n, (sigs, (packed, (action, ((counter, (threshold, keys)), tt))))))) psi <-> + env threshold n sigs packed action counter keys psi fuel : + 4 <= fuel -> + precond (eval_seq env multisig_tail fuel (threshold, (n, (sigs, (packed, (action, ((counter, (threshold, keys)), tt))))))) psi <-> ((threshold <= n)%N /\ match action with | inl (amout, contr) => @@ -467,23 +493,25 @@ Lemma multisig_tail_correct Proof. intro Hfuel. change (data (list key)) in keys. - rewrite eval_precond_correct. + rewrite eval_seq_precond_correct. unfold multisig_tail. - do 6 more_fuel. + repeat more_fuel. + unfold eval_seq_precond. simpl. + rewrite match_if_exchange. rewrite if_false_is_and. rewrite (leb_le nat). unfold lt, lt_comp, compare, simple_compare. rewrite N.compare_lt_iff. rewrite <- N.le_lteq. apply and_both. - repeat more_fuel. - simpl. destruct action as [(amount, contract)|[delegate_key_hash|(new_threshold, new_keys)]]; reflexivity. Qed. + Lemma multisig_correct + (env : @proto_env (Some (parameter_ty, None))) (counter : N) (action : data action_ty) (sigs : Datatypes.list (Datatypes.option (data signature))) @@ -498,100 +526,81 @@ Lemma multisig_correct let params : data parameter_ty := ((counter, action), sigs) in let storage : data storage_ty := (stored_counter, (threshold, keys)) in let new_storage : data storage_ty := (new_stored_counter, (new_threshold, new_keys)) in - 14 * length keys + 37 <= fuel -> - eval env multisig fuel ((params, storage), tt) = Return ((returned_operations, new_storage), tt) <-> - multisig_spec counter action sigs stored_counter threshold keys new_stored_counter new_threshold new_keys returned_operations. + length keys + 7 <= fuel -> + eval_seq env multisig fuel ((params, storage), tt) = Return ((returned_operations, new_storage), tt) <-> + multisig_spec env counter action sigs stored_counter threshold keys new_stored_counter new_threshold new_keys returned_operations. Proof. intros params storage new_storage Hfuel. - rewrite return_precond. rewrite multisig_split. + rewrite return_precond. rewrite PeanoNat.Nat.add_comm in Hfuel. - do 10 more_fuel. - change (S (S (S (S (S (S (S (S (S (S fuel)))))))))) with (10 + fuel). unfold params, storage. - rewrite multisig_head_correct. - - unfold multisig_head_spec, multisig_spec. - apply and_both_2. - intro; subst counter. - clear params. - unfold eval. - rewrite eval_precond_correct. - more_fuel; simpl. - match goal with - | |- eval_precond fuel env ?i ?t ?st <-> ?r => - pose (t) as then_; change (eval_precond fuel env i then_ st <-> r) - end. - more_fuel; simpl. - more_fuel; simpl. - more_fuel; simpl. - simpl. - match goal with - | |- eval_precond fuel env ?i ?t ?st <-> ?r => - pose (t) as iter; change (eval_precond fuel env i iter st <-> r) - end. - more_fuel. simpl. - subst iter. - rewrite <- eval_precond_correct. - rewrite multisig_iter_correct. - apply forall_ex; intro first_sigs. - apply forall_ex; intro remaining_sigs. - rewrite and_comm_3. - apply and_both. - apply and_both. - apply and_both. - unfold then_. - rewrite <- eval_precond_correct. - rewrite multisig_tail_correct. - rewrite N.add_0_r. - rewrite N.ge_le_iff. - apply and_both. - destruct action as [(amount, contr)|[delegate_key_hash|(new_t, new_k)]]. - + split. - * intro H. - injection H. - intro; subst keys. - intro; subst threshold. - intro; subst new_stored_counter. - intro; subst returned_operations. - intuition reflexivity. - * intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). - subst new_stored_counter; subst keys; subst threshold; subst returned_operations. - reflexivity. - + split. - * intros H. - injection H. - intro; subst keys. - intro; subst threshold. - intro; subst new_stored_counter. - intro; subst returned_operations. - intuition reflexivity. - * intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). - subst new_stored_counter; subst keys; subst threshold; subst returned_operations. - reflexivity. - + split. - * intro H. - injection H. - intro; subst new_keys. - intro; subst new_threshold. - intro; subst new_stored_counter. - intro; subst returned_operations. - intuition reflexivity. - * intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). - subst new_stored_counter; subst new_keys; subst new_threshold; subst returned_operations. - reflexivity. - + repeat apply Le.le_n_S. - refine (NPeano.Nat.le_trans _ _ _ _ Hfuel). - repeat apply Le.le_n_S. - apply le_0_n. - + rewrite PeanoNat.Nat.add_comm. - apply Le.le_n_S. - refine (NPeano.Nat.le_trans _ _ _ _ Hfuel). - repeat constructor. - rewrite PeanoNat.Nat.mul_comm. - constructor. - - refine (NPeano.Nat.le_trans _ _ _ _ Hfuel). - repeat apply Le.le_n_S. - apply le_0_n. + rewrite eval_seq_precond_correct. + rewrite eval_seq_assoc. + rewrite multisig_head_correct; [|lia]. + unfold multisig_head_spec, multisig_spec. + apply and_both_2. + intro; subst counter. + clear params. + unfold eval_seq_precond. + remember multisig_iter as iter. + remember multisig_tail as tail. + simpl. + more_fuel; simpl. + more_fuel; simpl. + subst iter. + rewrite fold_eval_precond. + rewrite <- eval_precond_correct. + rewrite multisig_iter_correct; [|rewrite NPeano.Nat.add_comm; apply Le.le_n_S; apply Hfuel]. + apply forall_ex; intro first_sigs. + apply forall_ex; intro remaining_sigs. + rewrite and_comm_3. + apply and_both. + apply and_both. + apply and_both. + change (@eval_precond_body (@eval_precond fuel)) with (@eval_precond (S fuel)). + change (@eval_precond_body (@eval_precond (S fuel))) with (@eval_precond (S (S fuel))). + rewrite fold_eval_seq_precond. + rewrite <- eval_seq_precond_correct. + subst tail. + rewrite multisig_tail_correct; [|lia]. + rewrite N.add_0_r. + rewrite N.ge_le_iff. + apply and_both. + destruct action as [(amount, contr)|[delegate_key_hash|(new_t, new_k)]]. + - split. + + intro H. + injection H. + intro; subst keys. + intro; subst threshold. + intro; subst new_stored_counter. + intro; subst returned_operations. + intuition reflexivity. + + intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). + subst new_stored_counter; subst keys; subst threshold; subst returned_operations. + reflexivity. + - split. + + intros H. + injection H. + intro; subst keys. + intro; subst threshold. + intro; subst new_stored_counter. + intro; subst returned_operations. + intuition reflexivity. + + intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). + subst new_stored_counter; subst keys; subst threshold; subst returned_operations. + reflexivity. + - split. + + intro H. + injection H. + intro; subst new_keys. + intro; subst new_threshold. + intro; subst new_stored_counter. + intro; subst returned_operations. + intuition reflexivity. + + intros (Hcounter, (Hthreshold, (Hkeys, Hoper))). + subst new_stored_counter; subst new_keys; subst new_threshold; subst returned_operations. + reflexivity. Qed. End multisig. diff --git a/src/contracts_coq/return_to_sender.v b/src/contracts_coq/return_to_sender.v deleted file mode 100644 index 1041de8ed99e6c668afee0884a2b5d6b168b0065..0000000000000000000000000000000000000000 --- a/src/contracts_coq/return_to_sender.v +++ /dev/null @@ -1,137 +0,0 @@ -(* Open Source License *) -(* Copyright (c) 2019 Nomadic Labs. *) - -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"), *) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) - -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) - -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) - -Require Import Michocoq.macros. -Import syntax. -Import comparable. -Require Import ZArith. -Require Import semantics. -Require Import util. -Import error. -Require List. - -Definition parameter_ty := unit. -Definition storage_ty := unit. - -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. - -Module return_to_sender(C:ContractContext)(E:Env ST C). - -Module semantics := Semantics ST C E. Import semantics. - -Definition return_to_sender : full_contract _ ST.self_type storage_ty := - ( - CDR ;; - NIL operation ;; - AMOUNT;; - PUSH mutez (0 ~mutez);; - IFCMPEQ NOOP - ( - SOURCE ;; - CONTRACT unit ;; - ASSERT_SOME ;; - AMOUNT ;; - UNIT ;; - TRANSFER_TOKENS ;; - CONS - );; - PAIR - ). - -Lemma eqb_eq a c1 c2 : - BinInt.Z.eqb (comparison_to_int (compare a c1 c2)) Z0 = true <-> - c1 = c2. -Proof. - rewrite BinInt.Z.eqb_eq. - rewrite comparison_to_int_Eq. - apply comparable.compare_eq_iff. -Qed. - -Lemma eqb_neq a c1 c2 : - BinInt.Z.eqb (comparison_to_int (compare a c1 c2)) Z0 = false <-> - c1 <> c2. -Proof. - split. - - intros Hf He. - rewrite <- eqb_eq in He. - congruence. - - intro Hneq. - rewrite <- eqb_eq in Hneq. - destruct ((comparison_to_int (compare a c1 c2) =? 0)%Z); congruence. -Qed. - -Lemma return_to_sender_correct : - forall (ops : data (list operation)) (fuel : Datatypes.nat), - fuel >= 42 -> - eval env return_to_sender fuel ((tt, tt), tt) = Return ((ops, tt), tt) - <-> - (amount env = (0 ~Mutez) /\ ops = nil) \/ - (amount env <> (0 ~Mutez) /\ - exists ctr, contract_ env unit (source env) = Some ctr /\ - ops = ((transfer_tokens env unit tt (amount env) ctr) :: nil)%list). -Proof. - intros ops fuel Hfuel. - rewrite return_precond. - unfold eval. - rewrite eval_precond_correct. - unfold ">=" in Hfuel. - do 8 (more_fuel ; simpl). - fold (simple_compare mutez). - fold (compare mutez). - case_eq ((comparison_to_int (compare mutez (0 ~Mutez) (amount env)) =? 0)%Z). - - (* true *) - intro Heq. - rewrite eqb_eq in Heq. - do 1 (more_fuel ; simpl). - split. - + intro Hops. - injection Hops. - intro; subst ops. - intuition. - + intros [(Hl, Hops)|(Hr, _)]. - * simpl. - subst; reflexivity. - * symmetry in Heq. - contradiction. - - intro Hneq. - rewrite eqb_neq in Hneq. - do 7 (more_fuel ; simpl). - destruct (contract_ env unit (source env)). - + (* Some *) - split. - * intro H ; right; split. - -- congruence. - -- eexists ; intuition ; injection H. - symmetry; assumption. - * intros [(Habs, _)| (_, (ctr, (He, Hops)))]. - -- congruence. - -- injection He; intro; subst d; subst ops; reflexivity. - + (* None *) - simpl. split. - * intro H; inversion H. - * intros [(Habs, _)|(ctr, (He, (Hops, _)))]. - -- congruence. - -- discriminate. -Qed. - -End return_to_sender. diff --git a/src/contracts_coq/vote.v b/src/contracts_coq/vote.v index b61971940e25e29bc82cd2944f1458fca7b61681..64d9c5618b2f4cb2d5de8c40e4d971e72c0b4d83 100644 --- a/src/contracts_coq/vote.v +++ b/src/contracts_coq/vote.v @@ -29,30 +29,25 @@ Require map. Definition parameter_ty : type := string. Definition storage_ty := map string int. +Module vote(C:ContractContext). +Module semantics := Semantics C. Import semantics. -Module ST : (SelfType with Definition self_type := parameter_ty). - Definition self_type := parameter_ty. -End ST. - -Module vote(C:ContractContext)(E:Env ST C). - -Module semantics := Semantics ST C E. Import semantics. - -Definition vote : full_contract _ ST.self_type storage_ty := - ( - AMOUNT ;; - PUSH mutez (5000000 ~mutez);; - COMPARE;; GT;; - IF ( FAIL ) ( NOOP );; - DUP;; DIP1 ( CDR;; DUP );; CAR;; DUP;; - DIP1 ( - GET (i := get_map string int);; ASSERT_SOME;; - PUSH int (Int_constant 1%Z);; ADD (s := add_int_int);; SOME - );; - UPDATE (i := Mk_update string (option int) (map string int) (Update_variant_map string int));; - NIL operation;; PAIR ). +Definition vote : full_contract _ parameter_ty None storage_ty := + { + AMOUNT ; + PUSH mutez (5000000 ~mutez); + COMPARE; GT; + IF_TRUE { FAIL } {}; + DUP; DIP1 { CDR; DUP }; CAR; DUP; + DIP1 { + (GET (i := get_map string int)); ASSERT_SOME; + PUSH int (Int_constant 1%Z); (ADD (s := add_int_int)); SOME + }; + (UPDATE (i := Mk_update string (option int) (map string int) (Update_variant_map string int))); + (NIL operation); PAIR }. Definition vote_spec + (env : @proto_env (Some (parameter_ty, None))) (storage: data storage_ty) (param : data parameter_ty) (new_storage : data storage_ty) @@ -84,20 +79,23 @@ Proof. Defined. Theorem vote_correct + (env : @proto_env (Some (parameter_ty, None))) (storage : data storage_ty) (param : data parameter_ty) (new_storage : data storage_ty) (returned_operations : data (list operation)) (fuel : Datatypes.nat) : fuel >= 42 -> - eval env vote fuel ((param, storage), tt) = Return ((returned_operations, new_storage), tt) - <-> vote_spec storage param new_storage returned_operations. + eval_seq env vote fuel ((param, storage), tt) = Return ((returned_operations, new_storage), tt) + <-> vote_spec env storage param new_storage returned_operations. Proof. intro Hfuel. unfold ">=" in Hfuel. unfold eval. rewrite return_precond. - rewrite eval_precond_correct. - do 15 (more_fuel; simpl). + rewrite eval_seq_precond_correct. + unfold eval_seq_precond. + do 3 (more_fuel; simpl). + rewrite match_if_exchange. rewrite if_false_not. apply and_both_0. - change (tez.compare (5000000 ~Mutez) (amount env)) with @@ -108,7 +106,6 @@ Proof. - (* Enough tez sent to contract *) destruct (map.get str Z string_compare param storage) eqn:mapget. + (* Key is in the map *) - more_fuel; simpl. split; intros. * (* -> *) simpl in *. diff --git a/src/michocoq/bytes_repr.v b/src/michocoq/bytes_repr.v new file mode 100644 index 0000000000000000000000000000000000000000..553181ef3bbb694f1f5f0023a6418291531c8554 --- /dev/null +++ b/src/michocoq/bytes_repr.v @@ -0,0 +1,250 @@ +(* Open Source License *) +(* Copyright (c) 2020 Nomadic Labs. *) + +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"), *) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) + +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) + +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) + + +(* Manipulation of sequences of bytes *) +Require Import String Ascii ZArith Lia. +Require error. +Import error.Notations. +Require Import ListString.All. + +Definition byte := ascii. +Definition bytes := string. + +Open Scope N_scope. +Open Scope char_scope. + +Definition is_hexa_char (c : ascii) : bool := + match c with + | "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" + | "a" | "A" | "b" | "B" | "c" | "C" | "d" | "D" | "e" | "E" | "f" | "F" => true + | _ => false + end. + +Definition read_hexa (c : ascii) : Bool.Is_true (is_hexa_char c) -> N := + match c with + | "0" => fun _ => 0 + | "1" => fun _ => 1 + | "2" => fun _ => 2 + | "3" => fun _ => 3 + | "4" => fun _ => 4 + | "5" => fun _ => 5 + | "6" => fun _ => 6 + | "7" => fun _ => 7 + | "8" => fun _ => 8 + | "9" => fun _ => 9 + | "a" | "A" => fun _ => 10 + | "b" | "B" => fun _ => 11 + | "c" | "C" => fun _ => 12 + | "d" | "D" => fun _ => 13 + | "e" | "E" => fun _ => 14 + | "f" | "F" => fun _ => 15 + | c => fun H => match H with end + end. + +Definition pp_hexa (n : N) (H : n < 16) : ascii := + if (n m < n \/ m = n. +Proof. + lia. +Qed. + +Lemma arith_aux2 n : n < 1 <-> n = 0. +Proof. + lia. +Qed. + +Lemma is_hexa_pp_hexa n H : Bool.Is_true (is_hexa_char (pp_hexa n H)). +Proof. + assert (n < 16) as H' by assumption. + rewrite (arith_aux n 15) in H'. + rewrite (arith_aux n 14) in H'. + rewrite (arith_aux n 13) in H'. + rewrite (arith_aux n 12) in H'. + rewrite (arith_aux n 11) in H'. + rewrite (arith_aux n 10) in H'. + rewrite (arith_aux n 9) in H'. + rewrite (arith_aux n 8) in H'. + rewrite (arith_aux n 7) in H'. + rewrite (arith_aux n 6) in H'. + rewrite (arith_aux n 5) in H'. + rewrite (arith_aux n 4) in H'. + rewrite (arith_aux n 3) in H'. + rewrite (arith_aux n 2) in H'. + rewrite (arith_aux n 1) in H'. + repeat (destruct H' as [H'|He]; [|subst n; constructor]). + apply arith_aux2 in H'. + subst n; constructor. +Qed. + +Lemma read_pp_hexa n H : read_hexa (pp_hexa n H) (is_hexa_pp_hexa n H) = n. +Proof. + assert (n < 16) as H' by assumption. + rewrite (arith_aux n 15) in H'. + rewrite (arith_aux n 14) in H'. + rewrite (arith_aux n 13) in H'. + rewrite (arith_aux n 12) in H'. + rewrite (arith_aux n 11) in H'. + rewrite (arith_aux n 10) in H'. + rewrite (arith_aux n 9) in H'. + rewrite (arith_aux n 8) in H'. + rewrite (arith_aux n 7) in H'. + rewrite (arith_aux n 6) in H'. + rewrite (arith_aux n 5) in H'. + rewrite (arith_aux n 4) in H'. + rewrite (arith_aux n 3) in H'. + rewrite (arith_aux n 2) in H'. + rewrite (arith_aux n 1) in H'. + repeat (destruct H' as [H'|He]; [|subst n; reflexivity]). + apply arith_aux2 in H'. + subst n; reflexivity. +Qed. + +Lemma read_hexa_lt_16 c H : read_hexa c H < 16. +Proof. + destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; + simpl in H; try contradiction; simpl; lia. +Qed. + +Lemma pp_read_hexa c H : pp_hexa (read_hexa c H) (read_hexa_lt_16 c H) = ListString.Char.down_case c. +Proof. + destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]]; + simpl in H; try contradiction; reflexivity. +Qed. + +Definition read_2_hexa c1 H1 c2 H2 : N := + let n1 := read_hexa c1 H1 in + let n2 := read_hexa c2 H2 in + 16 * n1 + n2. + +Lemma read_2_hexa_lt_256 c1 H1 c2 H2 : read_2_hexa c1 H1 c2 H2 < 256. +Proof. + unfold read_2_hexa. + specialize (read_hexa_lt_16 c1 H1). + specialize (read_hexa_lt_16 c2 H2). + lia. +Qed. + +Definition high_half (n : N) (H : n < 256) : N := n / 16. +Definition low_half (n : N) (H : n < 256) : N := n mod 16. + +Lemma high_lt_16 n H : high_half n H < 16. +Proof. + apply (N.div_lt_upper_bound n 16 16). + - lia. + - exact H. +Qed. + +Lemma low_lt_16 n H : low_half n H < 16. +Proof. + apply N.mod_upper_bound. + lia. +Qed. + +Definition pp_2_hexa (n : N) (H : n < 256) := + let h := high_half n H in + let l := low_half n H in + let Hh : h < 16 := high_lt_16 n H in + let Hl : l < 16 := low_lt_16 n H in + let c1 := pp_hexa h Hh in + let c2 := pp_hexa l Hl in + String c1 (String c2 ""%string). + +Definition read_byte c1 H1 c2 H2 : byte := + ascii_of_N (read_2_hexa c1 H1 c2 H2). + +(* This is proved in stdlib but only from Coq 8.10. *) +Lemma N_ascii_bounded (a : ascii) : N_of_ascii a < 256. +Proof. + destruct a as [[|] [|] [|] [|] [|] [|] [|] [|]]; simpl; lia. +Qed. + +Definition pp_byte (b : byte) : string := + pp_2_hexa (N_of_ascii b) (N_ascii_bounded b). + +Close Scope N_scope. + +Fixpoint forallb {A} (P : A -> bool) (l : list A) : bool := + match l with + | nil => true + | cons a l => (P a && forallb P l)%bool + end. + +(* Redefinition of stdlib lemmas because we need them to compute *) +Definition andb_prop a b : (a && b)%bool = true -> a = true /\ b = true. +Proof. + destruct a; destruct b; try discriminate; split; reflexivity. +Defined. + +Definition andb_prop_elim a b : Bool.Is_true (a && b) -> Bool.Is_true a /\ Bool.Is_true b. +Proof. + destruct a; destruct b; try contradiction; split; constructor. +Defined. + +Fixpoint of_list_char (s : list ascii) (H : Bool.Is_true (forallb is_hexa_char s)) (Hl : (N.of_nat (List.length s) mod 2 = 0)%N) : bytes. +Proof. + destruct s as [|c1 [|c2 s]]. + - exact ""%string. + - simpl in Hl. + compute in Hl. + exfalso. + lia. + - change (Datatypes.length (c1 :: c2 :: s)%list) with (2 + Datatypes.length s) in Hl. + rewrite Nnat.Nat2N.inj_add in Hl. + rewrite <- N.add_mod_idemp_l in Hl; [|lia]. + simpl in Hl. + simpl in H. + apply andb_prop_elim in H. + destruct H as (H1, H). + apply andb_prop_elim in H. + destruct H as (H2, H). + apply (String (read_byte c1 H1 c2 H2)). + apply (of_list_char s H Hl). +Defined. + +Definition of_string (s : string) : option bytes. +Proof. + pose (l := LString.of_string s). + case_eq (forallb is_hexa_char l && (N.of_nat (List.length l) mod 2 =? 0)%N)%bool. + - intro Htrue. + apply andb_prop in Htrue. + destruct Htrue as (H, Hl). + apply error.IT_eq_rev in H. + apply Neqb_ok in Hl. + apply Some. + apply (of_list_char l H Hl). + - intro; apply None. +Defined. + +Fixpoint to_string (bs : bytes) : string := + match bs with + | ""%string => ""%string + | String b bs => + pp_byte b ++ to_string bs + end. + +Eval compute in + (match of_string "0123456789abcdefABCDEF" with + | Some bs => Some (to_string bs) + | None => None + end). + diff --git a/src/michocoq/comparable.v b/src/michocoq/comparable.v index 23c2ebe56b54349aea60b75bef04b3bfb5d9f137..af3e942967d893195165cbd1516f4523146515e4 100644 --- a/src/michocoq/comparable.v +++ b/src/michocoq/comparable.v @@ -271,9 +271,13 @@ Proof. apply (string_compare_Lt_trans _ s2); assumption. Qed. +(* Not documented, see contract_repr.ml in the Tezos protocol *) Definition address_compare (a1 a2 : address_constant) : comparison := match a1, a2 with - | Mk_address s1, Mk_address s2 => string_compare s1 s2 + | Implicit (Mk_key_hash s1), Implicit (Mk_key_hash s2) => string_compare s1 s2 + | Originated (Mk_smart_contract_address s1), Originated (Mk_smart_contract_address s2) => string_compare s1 s2 + | Implicit _, Originated _ => Lt + | Originated _, Implicit _ => Gt end. Definition key_hash_compare (h1 h2 : key_hash_constant) : comparison := @@ -341,9 +345,8 @@ Proof. - apply string_compare_Eq_correct. - destruct c1; destruct c2; split; simpl; congruence. - apply tez.compare_eq_iff. - - destruct c1 as [s1]; destruct c2 as [s2]. simpl. - rewrite string_compare_Eq_correct. - split; congruence. + - destruct c1 as [[s1]|[s1]]; destruct c2 as [[s2]|[s2]]; simpl; + try rewrite string_compare_Eq_correct; split; congruence. - destruct c1 as [s1]; destruct c2 as [s2]. simpl. rewrite string_compare_Eq_correct. split; congruence. @@ -399,8 +402,11 @@ Proof. - apply string_compare_Lt_trans. - unfold lt_comp; destruct x; destruct y; destruct z; simpl; congruence. - apply Z.lt_trans. - - destruct x as [x]; destruct y as [y]; destruct z as [z]. - apply string_compare_Lt_trans. + - unfold lt_comp; + destruct x as [[x]|[x]]; + destruct y as [[y]|[y]]; + destruct z as [[z]|[z]]; simpl; + try reflexivity; try discriminate; apply string_compare_Lt_trans. - destruct x as [x]; destruct y as [y]; destruct z as [z]. apply string_compare_Lt_trans. - apply Z.lt_trans. @@ -462,8 +468,11 @@ Proof. - unfold gt_comp. destruct x; destruct y; destruct z; simpl; congruence. - apply Zcompare_Gt_trans. - - destruct x as [x]; destruct y as [y]; destruct z as [z]. - apply string_compare_Gt_trans. + - unfold gt_comp; + destruct x as [[x]|[x]]; + destruct y as [[y]|[y]]; + destruct z as [[z]|[z]]; simpl; + try reflexivity; try discriminate; apply string_compare_Gt_trans. - destruct x as [x]; destruct y as [y]; destruct z as [z]. apply string_compare_Gt_trans. - apply Zcompare_Gt_trans. @@ -486,3 +495,8 @@ Proof. apply map.compare_diff. apply compare_eq_iff. Qed. + +Lemma comparable_data_dec {a : comparable_type} : decidable_types.decidable (comparable_data a). +Proof. + apply (decidable_types.comparable_decidable (compare_eq_iff a)). +Qed. diff --git a/src/michocoq/decidable_types.v b/src/michocoq/decidable_types.v new file mode 100644 index 0000000000000000000000000000000000000000..19265ff6085fa49d8bd1de6c87a3691cd6379474 --- /dev/null +++ b/src/michocoq/decidable_types.v @@ -0,0 +1,89 @@ +Require Eqdep_dec String. +Require Import ZArith. + +Definition decidable (A : Set) := forall x y : A, {x = y} + {x <> y}. + +Lemma decidable_UIP {A : Set} : decidable A -> forall x y : A, forall H1 H2 : x = y, H1 = H2. +Proof. + apply Eqdep_dec.UIP_dec. +Qed. + +Lemma decidable_UIP_refl {A : Set} : decidable A -> forall x : A, forall H : x = x, H = eq_refl. +Proof. + intros HA x H. + apply decidable_UIP. + assumption. +Qed. + +Lemma nat_dec : decidable nat. + unfold decidable. + decide equality. +Defined. + +Lemma Z_dec : decidable Z. + unfold decidable. + repeat decide equality. +Defined. + +Lemma string_dec : decidable String.string. + exact String.string_dec. +Defined. + +Lemma list_dec {A : Set} : decidable A -> decidable (Datatypes.list A). +Proof. + unfold decidable. + decide equality. +Defined. + +Lemma option_dec {A : Set} : decidable A -> decidable (Datatypes.option A). +Proof. + unfold decidable. + decide equality. +Defined. + +Lemma pair_dec {A B : Set} : decidable A -> decidable B -> decidable (A * B). +Proof. + unfold decidable. + decide equality. +Defined. + +Lemma or_dec {A B : Set} : decidable A -> decidable B -> decidable (A + B). +Proof. + unfold decidable. + decide equality. +Defined. + +Lemma sigT_dec {A : Set} {B : A -> Set} : + decidable A -> + (forall x : A, decidable (B x)) -> + decidable (sigT B). +Proof. + intros HA HB xy1 xy2. + case (HA (projT1 xy1) (projT1 xy2)). + - intro Hx. + case (HB _ (projT2 xy2) (eq_rec (projT1 xy1) B (projT2 xy1) (projT1 xy2) Hx)). + + intro Hy. + left. + destruct xy1 as (x1, y1). + destruct xy2 as (x2, y2). + simpl in *. + destruct Hx. + simpl in Hy. + congruence. + + intro Hy. + right; intro Hxy. + destruct Hxy. + assert (Hx = eq_refl) by (apply decidable_UIP_refl; assumption). + subst Hx. + simpl in Hy. + congruence. + - intuition congruence. +Defined. + +Lemma comparable_decidable {A : Set} {compare : A -> A -> comparison} : + (forall x y : A, compare x y = Eq <-> x = y) -> + decidable A. +Proof. + intros Hcomparable x y. specialize (Hcomparable x y). + case_eq (compare x y); intuition congruence. +Defined. diff --git a/src/michocoq/dummy_contract_context.v b/src/michocoq/dummy_contract_context.v deleted file mode 100644 index d0ebe7e4c812699e3a35ca615cbb47d394d0ca63..0000000000000000000000000000000000000000 --- a/src/michocoq/dummy_contract_context.v +++ /dev/null @@ -1,4 +0,0 @@ -Require syntax. -Require syntax_type. -Definition get_contract_type (_ : syntax.contract_constant) : - Datatypes.option syntax_type.type := None. diff --git a/src/michocoq/error.v b/src/michocoq/error.v index b93073b2b9e90669f5554b6310e2976f7c5ca5de..14597f8d2f4bb1cb5730540dcece7ba023e77e39 100644 --- a/src/michocoq/error.v +++ b/src/michocoq/error.v @@ -20,7 +20,8 @@ (* DEALINGS IN THE SOFTWARE. *) -(* The error monad *) +(* The error monad, and various basic stuff *) + Require Bool String. Require Import location. Require Import syntax_type. @@ -34,7 +35,9 @@ Inductive exception : Type := | Parsing_Out_of_Fuel | Expansion (_ _ : location) | Expansion_prim (_ _ : location) (_ : String.string) -| Typing (A : Set) (a : A). +| Typing (A : Set) (a : A) +| Unit_test (input expected actual : String.string) +| Debug (_ : String.string). Inductive M (A : Type) : Type := | Failed : exception -> M A @@ -42,12 +45,29 @@ Inductive M (A : Type) : Type := Arguments Return {_} _. +Lemma unreturn {A} (a b : A) : error.Return a = error.Return b -> a = b. +Proof. + congruence. +Qed. + Definition bind {A B : Type} (m : M A) (f : A -> M B) := match m with | Failed _ e => Failed B e | Return SB => f SB end. +Definition opt_bind {A B : Set} (m : Datatypes.option A) (f : A -> Datatypes.option B) : Datatypes.option B := + match m with + | Some a => f a + | None => None + end. + +Definition opt_merge {A : Set} (m1 m2 : Datatypes.option A) : Datatypes.option A := + match m1 with + | Some a1 => Some a1 + | None => m2 + end. + Module Notations. (** Notation for the bind with a typed answer. *) Notation "'let!' x : A ':=' X 'in' Y" := @@ -58,6 +78,16 @@ Module Notations. Notation "'let!' x ':=' X 'in' Y" := (bind X (fun x => Y)) (at level 200, x pattern, X at level 100, Y at level 200). + + (** Same for the option monad. *) + Notation "'let?' x : A ':=' X 'in' Y" := + (opt_bind X (fun (x : A) => Y)) + (at level 200, x pattern, X at level 100, A at level 200, Y at level 200). + + (** Notation for the bind. *) + Notation "'let?' x ':=' X 'in' Y" := + (opt_bind X (fun x => Y)) + (at level 200, x pattern, X at level 100, Y at level 200). End Notations. Import Notations. @@ -91,14 +121,16 @@ Definition success {A} (m : M A) := | Return _ => true end. +Lemma bool_dec (b1 b2 : Datatypes.bool) : { b1 = b2 } + { b1 <> b2 }. +Proof. + repeat decide equality. +Qed. + Definition Is_true := Bool.Is_true. -Lemma Is_true_UIP b : forall x y : Is_true b, x = y. +Lemma Is_true_UIP b (x y : Is_true b) : x = y. Proof. - destruct b. - - intros [] []. - reflexivity. - - contradiction. + destruct b; destruct x; destruct y; reflexivity. Defined. Coercion is_true := Is_true. @@ -177,15 +209,18 @@ Proof. reflexivity. Qed. -Lemma bind_eq_return {A B : Set} f (m : M A) (b : M B) : - (let! x := m in f x) = Return b -> +Lemma bind_eq_return {A B : Set} f (m : M A) (b : B) : + (let! x := m in f x) = Return b <-> exists a : A, m = Return a /\ f a = Return b. Proof. - destruct m. - - discriminate. - - simpl. - exists a. - auto. + split. + - destruct m. + + discriminate. + + simpl. + exists a. + auto. + - intros (a, (Hm, Hb)). + subst m; exact Hb. Qed. @@ -240,3 +275,84 @@ Proof. - intro H. apply H. Qed. + +Definition dif {A : Datatypes.bool -> Type} (b : Datatypes.bool) (t : b -> A b) (e : negb b -> A b) : A b. +Proof. + destruct b; [apply t | apply e]; constructor. +Defined. + +Lemma dif_case {A : Datatypes.bool -> Type} {b t e} {P : A b -> Prop} : (forall h, P (t h)) -> (forall h, P (e h)) -> P (dif b t e). +Proof. + unfold dif. + destruct b. + - intros H _; apply H. + - intros _ H; apply H. +Defined. + +(* Lemmas about sigT *) + +Definition sigT_eq_1 {A} (P : A -> Set) (xa yb : sigT P) : xa = yb -> projT1 xa = projT1 yb. +Proof. + apply f_equal. +Defined. + +Definition sigT_eq_2 {A} (P : A -> Set) (xa yb : sigT P) (H : xa = yb) : + eq_rec (projT1 xa) P (projT2 xa) (projT1 yb) (sigT_eq_1 P xa yb H) = projT2 yb. +Proof. + subst xa. + reflexivity. +Defined. + +Definition existT_eq_1 {A} (P : A -> Set) x y a b : existT P x a = existT P y b -> x = y. +Proof. + apply (f_equal (@projT1 A P)). +Defined. + +Definition existT_eq_2 {A} (P : A -> Set) x y a b (H : existT P x a = existT P y b ) : + eq_rec x P a y (existT_eq_1 P x y a b H) = b. +Proof. + apply (sigT_eq_2 P (existT P x a) (existT P y b)). +Defined. + +Definition existT_eq_3 {A} (P : A -> Set) x y a b : + existT P x a = existT P y b -> + sig (fun H : x = y => eq_rec x P a y H = b). +Proof. + intro H. + exists (existT_eq_1 P x y a b H). + apply existT_eq_2. +Defined. + +(* Same about sig *) + +Definition sig_eq_1 {A} (P : A -> Prop) (xa yb : sig P) : xa = yb -> proj1_sig xa = proj1_sig yb. +Proof. + apply f_equal. +Defined. + +Definition sig_eq_2 {A} (P : A -> Prop) (xa yb : sig P) (H : xa = yb) : + eq_rec (proj1_sig xa) P (proj2_sig xa) (proj1_sig yb) (sig_eq_1 P xa yb H) = proj2_sig yb. +Proof. + subst xa. + reflexivity. +Defined. + +Definition exist_eq_1 {A} (P : A -> Prop) x y a b : exist P x a = exist P y b -> x = y. +Proof. + apply (f_equal (@proj1_sig A P)). +Defined. + +Definition exist_eq_2 {A} (P : A -> Prop) x y a b (H : exist P x a = exist P y b ) : + eq_rec x P a y (exist_eq_1 P x y a b H) = b. +Proof. + apply (sig_eq_2 P (exist P x a) (exist P y b)). +Defined. + +Definition exist_eq_3 {A} (P : A -> Prop) x y a b : + exist P x a = exist P y b -> + sig (fun H : x = y => eq_rec x P a y H = b). +Proof. + intro H. + exists (exist_eq_1 P x y a b H). + apply exist_eq_2. +Defined. diff --git a/src/michocoq/error_pp.v b/src/michocoq/error_pp.v index defdec43d6f799597f4cfc2b2840d72ed6b0e9f3..c678dc49195e0a9fa1aa15b2c1d95facfa108902 100644 --- a/src/michocoq/error_pp.v +++ b/src/michocoq/error_pp.v @@ -17,10 +17,19 @@ Definition exception_pp (e : exception) : string := | Expansion b e => "Expansion error between " ++ location_pp b ++ " and " ++ location_pp e | Expansion_prim b e s => "Unknown primitive " ++ s ++ " between " ++ location_pp b ++ " and " ++ location_pp e | Typing _ _ => "Typing error" + | Unit_test input expected actual => + let input := if String.length input " in + let expected := if String.length expected " in + let actual := if String.length actual " in + "Unit test failed" ++ lf ++ + " input: {" ++ input ++ "}" ++ lf ++ + " expected output: {" ++ expected ++ "}" ++ lf ++ + " actual output: {" ++ actual ++ "}" + | Debug s => "Debug: " ++ s end. Definition m_pp {A} (m : M A) : string := match m with | Return _ => "OK" - | Failed _ e => exception_pp e + | Failed _ e => "KO: " ++ exception_pp e end. diff --git a/src/michocoq/extraction/Makefile.local b/src/michocoq/extraction/Makefile.local index aae70dbad11f9af264e6057af4ee0189388658aa..1e5db0d208245b513d1a5cb514188af698e4bba0 100644 --- a/src/michocoq/extraction/Makefile.local +++ b/src/michocoq/extraction/Makefile.local @@ -30,8 +30,9 @@ zarith.mli: %.ml: %.ml.hand-written cp $< $@ -post-all:: michocoq.ml extraction.vo zarith.ml zarith.mli +post-all:: michocoq.ml michocoq-tzt.ml extraction.vo zarith.ml zarith.mli ocamlbuild -package zarith michocoq.native + ocamlbuild -package zarith michocoq-tzt.native clean-extracted: rm -f *.ml *.mli *.cmi *.cmo *.native diff --git a/src/michocoq/extraction/extraction.v b/src/michocoq/extraction/extraction.v index 7a0330742d85ddacd9a8de782a77820b7a5f3732..ab78424690daae685a3f10f54a519da6ed5fa5e1 100644 --- a/src/michocoq/extraction/extraction.v +++ b/src/michocoq/extraction/extraction.v @@ -28,11 +28,11 @@ Extract Constant Ascii.ascii_of_pos => "(fun x -> Char.chr (Zarith.to_int x))". (* Require Import Michocoq.semantics. *) (* Recursive Extraction Library semantics. *) Require Import Michocoq.comparable Michocoq.int64bv Michocoq.typer Michocoq.micheline_lexer Michocoq.micheline_parser -Michocoq.micheline2michelson Michocoq.main. +Michocoq.micheline2michelson Michocoq.semantics Michocoq.main. (* Recursive Extraction Library micheline_lexer. *) (* Recursive Extraction Library micheline_parser. *) -Extract Inlined Constant ascii_compare => "(fun c1 c2 -> if (c1 < c2) then cl else if (c1 > c2) then Gt else Eq)". +Extract Inlined Constant ascii_compare => "(fun c1 c2 -> if (c1 < c2) then Lt else if (c1 > c2) then Gt else Eq)". Require Import ZArith NArith. @@ -85,6 +85,17 @@ Extract Constant Z.opp => "Zarith.neg". Extract Constant Z.abs => "Zarith.abs". Extract Constant Z.min => "Zarith.min". Extract Constant Z.max => "Zarith.max". +Extract Constant Z.land => "Zarith.logand". +Extract Constant ediv_Z => "fun x y -> try + let (q, r) = Zarith.ediv_rem x y in + Some (q, r) + with _ -> None". + + +Extract Constant Z.div => + "fun a b -> Zarith.(if b = zero then zero else Zarith.div a b)". +Extract Constant Z.modulo => + "fun a b -> Zarith.(if b = zero then zero else Zarith.rem a b)". Extract Constant Z.compare => "fun x y -> Zarith.(if x < y then Lt else if x > y then Gt else Eq)". Extract Constant Z.of_N => "fun p -> p". @@ -95,9 +106,12 @@ Extract Constant Zdigits.Zmod2 => "fun x -> Zarith.ediv x (Zarith.add Zarith.one Extract Inlined Constant int64 => "int64". Extract Inlined Constant sign => "(fun x -> Int64.compare x 0L < 0)". Extract Inlined Constant to_Z => "Zarith.of_int64". -Extract Inlined Constant of_Z => "Zarith.to_int64". +Extract Inlined Constant of_Z_unsafe => "Zarith.to_int64". -Recursive Extraction Library main. +(* Avoid a name collision for the module [Char] from the [coq-list-string] + library. *) +Extraction Blacklist Char. +Separate Extraction main. (* Require Import Michocoq.main. *) (* Recursive Extraction Library main. *) diff --git a/src/michocoq/extraction/michocoq-tzt.ml.hand-written b/src/michocoq/extraction/michocoq-tzt.ml.hand-written new file mode 100644 index 0000000000000000000000000000000000000000..5660053bcb80aede2717eb376c1fcadbca9a8de6 --- /dev/null +++ b/src/michocoq/extraction/michocoq-tzt.ml.hand-written @@ -0,0 +1,18 @@ +(* Conversion functions between Coq and OCaml strings, taken from CompCert. *) + +let camlstring_of_coqstring (s : char list) = + let r = Bytes.create (Stdlib.List.length s) in + let rec fill pos = function + | [] -> r + | c :: s -> Bytes.set r pos c; fill (pos + 1) s + in Bytes.to_string (fill 0 s) + +let coqstring_of_camlstring s = + let rec cstring accu pos = + if pos < 0 then accu else cstring (Stdlib.String.get s pos :: accu) (pos - 1) + in cstring [] (Stdlib.String.length s - 1) + +(* main entrypoint *) +let () = + if Array.length Sys.argv > 1 then + print_endline (camlstring_of_coqstring (Main0.print_info_tzt (coqstring_of_camlstring Sys.argv.(1)) Main0.fixed_fuel)); diff --git a/src/michocoq/extraction/michocoq.ml.hand-written b/src/michocoq/extraction/michocoq.ml.hand-written index 63ac130e5c4eea8081195f935a6376c3c6c8e943..16b1418982e7a9ba274ffaffa2f90a94eae73da3 100644 --- a/src/michocoq/extraction/michocoq.ml.hand-written +++ b/src/michocoq/extraction/michocoq.ml.hand-written @@ -1,11 +1,11 @@ (* Conversion functions between Coq and OCaml strings, taken from CompCert. *) let camlstring_of_coqstring (s : char list) = - let r = Bytes.create (Stdlib.List.length s) in + let r = Stdlib.Bytes.create (Stdlib.List.length s) in let rec fill pos = function | [] -> r - | c :: s -> Bytes.set r pos c; fill (pos + 1) s - in Bytes.to_string (fill 0 s) + | c :: s -> Stdlib.Bytes.set r pos c; fill (pos + 1) s + in Stdlib.Bytes.to_string (fill 0 s) let coqstring_of_camlstring s = let rec cstring accu pos = diff --git a/src/michocoq/int64bv.v b/src/michocoq/int64bv.v index aa2510927f8af90306f276d42a2f47ce63df590f..89c7d0e01303f5a6071f8950570b6a74c4272812 100644 --- a/src/michocoq/int64bv.v +++ b/src/michocoq/int64bv.v @@ -25,6 +25,8 @@ Require Import Bvector. Require Import ZArith. Require Import Zdigits. +Require Import Lia. +Require error. Definition int64 := Bvector 64. @@ -32,18 +34,142 @@ Definition sign : int64 -> bool := Bsign 63. Definition to_Z : int64 -> Z := two_compl_value 63. -Definition of_Z : Z -> int64 := Z_to_two_compl 63. +Lemma to_Z_lower_bound : forall b : int64, (- two_power_nat 63 <= to_Z b)%Z. +Proof. + unfold int64, to_Z. + generalize 63. + intros n b. + refine (@VectorDef.caseS + _ + (fun n b => - two_power_nat n <= two_compl_value n b)%Z + _ n b). + clear n b. + intros b n t. + simpl. + generalize b; clear b. + induction t. + + simpl. + unfold eq_rec_r. + simpl. + intro b; destruct b; simpl; omega. + + simpl two_compl_value. + unfold eq_rec_r. + simpl. + specialize (IHt h). + generalize IHt; clear IHt. + destruct (two_compl_value n (h :: t)). + * destruct b; simpl; nia. + * destruct b; simpl; nia. + * generalize (shift_nat n 1); intro p0; simpl. + destruct b; simpl; try nia. + apply Pos2Z.neg_le_neg. + unfold "<="%Z in IHt. + unfold "?="%Z in IHt. + rewrite <- Pos.compare_antisym in IHt. + change (p <= p0)%positive in IHt. + transitivity (p~0)%positive. + -- rewrite <- Pos.succ_pred_double. + lia. + -- nia. +Qed. + +Lemma to_Z_upper_bound : forall b : int64, (to_Z b < two_power_nat 63)%Z. + unfold int64, to_Z. + generalize 63. + intros n b. + refine (@VectorDef.caseS + _ + (fun n b => two_compl_value n b < two_power_nat n)%Z + _ n b). + clear n b. + intros b n t. + generalize b; clear b. + induction t. + + unfold two_power_nat. + simpl. + unfold eq_rec_r. + simpl. + intro b; destruct b; simpl; omega. + + simpl two_compl_value. + unfold eq_rec_r. + simpl. + specialize (IHt h). + generalize IHt; clear IHt. + unfold two_power_nat. + destruct (two_compl_value n (h :: t)). + * destruct b; simpl; nia. + * destruct b; simpl; nia. + * generalize (shift_nat n 1); intro p0; simpl. + destruct b; simpl; nia. +Qed. + +Definition of_Z_unsafe : Z -> int64 := Z_to_two_compl 63. + +Definition of_Z_safe (z : Z) : + ((z >=? - two_power_nat 63) && (z int64 := + fun _ => of_Z_unsafe z. + +Definition of_Z (z : Z) : error.M int64 := + if ((z >=? - two_power_nat 63) && (z ex_intro _ a (ex_intro _ v eq_refl) end. -Lemma of_Z_to_Z b : of_Z (to_Z b) = b. +Lemma of_Z_to_Z_eqv z b : to_Z b = z <-> of_Z z = error.Return b. Proof. - destruct (int64_inversion b) as (a, (v, H)). - rewrite H. - apply two_compl_to_Z_to_two_compl. + unfold of_Z, to_Z. + split. + - intro; subst z. + destruct (int64_inversion b) as (a, (v, H)). + rewrite H. + unfold of_Z_unsafe. + rewrite two_compl_to_Z_to_two_compl. + rewrite <- H; clear H. + assert ((two_compl_value 63 b >=? - two_power_nat 63)%Z = true) as Hlow. + + rewrite Z.geb_le. + apply to_Z_lower_bound. + + rewrite Hlow; clear Hlow. + assert ((two_compl_value 63 b =? - two_power_nat 63) && (z match o with error.Return x => x | _ => b end)) in H. + subst b. + apply andb_prop in Hcond. + destruct Hcond as (H1, H2). + apply Z_to_two_compl_to_Z. + * apply Z.le_ge. + apply Z.geb_le. + assumption. + * apply Z.ltb_lt. + assumption. + + intro Hcond. + rewrite Hcond in H. + discriminate. +Qed. + +Lemma of_Z_to_Z b : of_Z (to_Z b) = error.Return b. +Proof. + rewrite <- of_Z_to_Z_eqv. + reflexivity. Qed. Definition compare (a b : int64) : comparison := @@ -61,6 +187,7 @@ Proof. apply (f_equal of_Z) in H. rewrite of_Z_to_Z in H. rewrite of_Z_to_Z in H. - assumption. + injection H. + auto. - apply f_equal. Qed. diff --git a/src/michocoq/macros.v b/src/michocoq/macros.v index 5e3b0e463d1befc532bef2ef18aacc245f0358d1..116e22b3d39cdf128d58184951f16e7968027b2b 100644 --- a/src/michocoq/macros.v +++ b/src/michocoq/macros.v @@ -22,16 +22,12 @@ Require Import syntax syntax_type. Require Import comparable. -Module Macros(C : ContractContext). - -Module syntax := Syntax C. -Export syntax. - Section macros. - Context {self_type : Datatypes.option type}. + Context {self_type : self_info}. Definition CMPop (a : comparable_type) S (op : instruction self_type Datatypes.false (int ::: S) (bool ::: S)) - : instruction self_type Datatypes.false (a ::: a ::: S) (bool ::: S) := COMPARE ;; op. + : instruction self_type Datatypes.false (a ::: a ::: S) (bool ::: S) := + Instruction_seq { COMPARE; op }. Definition CMPEQ {a S} := CMPop a S EQ. Definition CMPNEQ {a S} := CMPop a S NEQ. @@ -40,10 +36,15 @@ Definition CMPGT {a S} := CMPop a S GT. Definition CMPLE {a S} := CMPop a S LE. Definition CMPGE {a S} := CMPop a S GE. +Definition wrap_IF {SA SB tffa tffb} (bt : instruction_seq self_type tffa SA SB) (bf : instruction_seq self_type tffb SA SB) + : instruction_seq self_type (tffa && tffb)%bool (bool ::: SA) SB := + instruction_wrap (IF_ IF_bool bt bf). + Definition IFop SA SB tffa tffb - (bt : instruction self_type tffa SA SB) (bf : instruction self_type tffb SA SB) - (op : instruction self_type Datatypes.false (int ::: SA) (bool ::: SA)) := - op ;; IF_ bt bf. + (bt : instruction_seq self_type tffa SA SB) (bf : instruction_seq self_type tffb SA SB) + (op : instruction self_type Datatypes.false (int ::: SA) (bool ::: SA)) + : instruction self_type (tffa && tffb)%bool (int ::: SA) SB := + Instruction_seq (op ;; wrap_IF bt bf). Definition IFEQ {SA SB tffa tffb} bt bf := IFop SA SB tffa tffb bt bf EQ. Definition IFNEQ {SA SB tffa tffb} bt bf := IFop SA SB tffa tffb bt bf NEQ. @@ -53,10 +54,10 @@ Definition IFLE {SA SB tffa tffb} bt bf := IFop SA SB tffa tffb bt bf LE. Definition IFGE {SA SB tffa tffb} bt bf := IFop SA SB tffa tffb bt bf GE. Definition IFCMPop (a : comparable_type) SA SB tffa tffb - (bt : instruction self_type tffa SA SB) (bf : instruction self_type tffb SA SB) + (bt : instruction_seq self_type tffa SA SB) (bf : instruction_seq self_type tffb SA SB) (op : instruction self_type Datatypes.false (int ::: SA) (bool ::: SA)) : instruction self_type (tffa && tffb) (a ::: a ::: SA) SB := - COMPARE ;; op ;; IF_ bt bf. + Instruction_seq (COMPARE ;; op ;; wrap_IF bt bf). Definition IFCMPEQ {a SA SB tffa tffb} bt bf := IFCMPop a SA SB tffa tffb bt bf EQ. Definition IFCMPNEQ {a SA SB tffa tffb} bt bf := IFCMPop a SA SB tffa tffb bt bf NEQ. @@ -65,12 +66,14 @@ Definition IFCMPGT {a SA SB tffa tffb} bt bf := IFCMPop a SA SB tffa tffb bt bf Definition IFCMPLE {a SA SB tffa tffb} bt bf := IFCMPop a SA SB tffa tffb bt bf LE. Definition IFCMPGE {a SA SB tffa tffb} bt bf := IFCMPop a SA SB tffa tffb bt bf GE. -Definition FAIL {SA SB} : instruction self_type Datatypes.true SA SB := UNIT ;; FAILWITH. +Definition FAIL {SA SB} : instruction self_type Datatypes.true SA SB := + Instruction_seq { UNIT; FAILWITH }. -Definition ASSERT {S} : instruction self_type Datatypes.false (bool ::: S) S := IF_ NOOP FAIL. +Definition ASSERT {S} : instruction self_type Datatypes.false (bool ::: S) S := + IF_ IF_bool {} { FAIL }. Definition ASSERT_op S (op : instruction self_type Datatypes.false (int ::: S) (bool ::: S)) : instruction self_type Datatypes.false (int ::: S) S := - IFop _ _ _ _ NOOP FAIL op. + IFop _ _ _ _ {} { FAIL } op. Definition ASSERT_EQ {S} := ASSERT_op S EQ. Definition ASSERT_NEQ {S} := ASSERT_op S NEQ. @@ -80,7 +83,8 @@ Definition ASSERT_LE {S} := ASSERT_op S LE. Definition ASSERT_GE {S} := ASSERT_op S GE. Definition ASSERT_CMPop (a : comparable_type) S (op : instruction self_type Datatypes.false (int ::: S) (bool ::: S)) - : instruction self_type Datatypes.false (a ::: a ::: S) S := IFCMPop _ _ _ _ _ NOOP FAIL op. + : instruction self_type Datatypes.false (a ::: a ::: S) S := + IFCMPop _ _ _ _ _ {} { FAIL } op. Definition ASSERT_CMPEQ {a S} := ASSERT_CMPop a S EQ. Definition ASSERT_CMPNEQ {a S} := ASSERT_CMPop a S NEQ. @@ -90,15 +94,16 @@ Definition ASSERT_CMPLE {a S} := ASSERT_CMPop a S LE. Definition ASSERT_CMPGE {a S} := ASSERT_CMPop a S GE. Definition ASSERT_NONE {a S} : instruction self_type Datatypes.false (option a ::: S) S := - IF_NONE NOOP FAIL. + IF_NONE {} { FAIL }. Definition ASSERT_SOME {a S} : instruction self_type Datatypes.false (option a ::: S) (a ::: S) := - IF_NONE FAIL NOOP. + IF_NONE { FAIL } {}. -Definition ASSERT_LEFT {a b S} : instruction self_type Datatypes.false (or a b ::: S) (a ::: S) := - IF_LEFT NOOP FAIL. -Definition ASSERT_RIGHT {a b S} : instruction self_type Datatypes.false (or a b ::: S) (b ::: S) := - IF_LEFT FAIL NOOP. +Definition ASSERT_LEFT {a b an bn S} : instruction self_type Datatypes.false (or a an b bn ::: S) (a ::: S) := + IF_LEFT {} { FAIL }. + +Definition ASSERT_RIGHT {a b an bn S} : instruction self_type Datatypes.false (or a an b bn ::: S) (b ::: S) := + IF_LEFT { FAIL } {}. Definition DROP1 {a SA} : instruction self_type Datatypes.false (a ::: SA) SA := DROP (A := a ::: nil) 1 eq_refl. @@ -115,10 +120,10 @@ Definition DIIIIP {a b c d SA SB} code : DIP (A := (a ::: b ::: c ::: d ::: nil)) 4 eq_refl code. Definition DUUP {a b S} : instruction self_type Datatypes.false (a ::: b ::: S) (b ::: a ::: b ::: S) := - DIP1 DUP ;; SWAP. + Instruction_seq { DIP1 { DUP }; SWAP }. Definition DUPn {A b C} n (H : length A = n) : instruction self_type Datatypes.false (A +++ b ::: C) (b ::: A +++ b ::: C) := - DIG n H ;; DUP ;; DIP1 (DUG n H). + Instruction_seq { DIG n H; DUP; DIP1 { DUG n H }}. Definition DUUUP {a b c S} : instruction self_type Datatypes.false (a ::: b ::: c ::: S) (c ::: a ::: b ::: c ::: S) := DUPn (A := a ::: b ::: nil) 2 eq_refl. @@ -129,42 +134,45 @@ Definition DUUUUP {a b c d S} : instruction self_type Datatypes.false (a ::: b : (* Missing: PAPPAIIR and such *) Definition UNPAIR {a b S} : instruction self_type Datatypes.false (pair a b ::: S) (a ::: b ::: S) := - DUP ;; CAR ;; DIP1 CDR. + Instruction_seq { DUP; CAR; DIP1 (instruction_wrap CDR) }%michelson. Definition CAAR {a b c S} : instruction self_type Datatypes.false (pair (pair a b) c ::: S) (a ::: S) := - CAR ;; CAR. + Instruction_seq { CAR; CAR }. Definition CADR {a b c S} : instruction self_type Datatypes.false (pair (pair a b) c ::: S) (b ::: S) := - CAR ;; CDR. + Instruction_seq { CAR; CDR}. Definition CDAR {a b c S} : instruction self_type Datatypes.false (pair a (pair b c) ::: S) (b ::: S) := - CDR ;; CAR. + Instruction_seq { CDR; CAR}. Definition CDDR {a b c S} : instruction self_type Datatypes.false (pair a (pair b c) ::: S) (c ::: S) := - CDR ;; CDR. + Instruction_seq { CDR; CDR}. -Definition IF_SOME {a SA SB tffa tffb} (bt : instruction self_type tffa _ _) (bf : instruction self_type tffb _ _) : instruction self_type _ (option a ::: SA) SB := +Definition IF_SOME {a SA SB tffa tffb} (bt : instruction_seq self_type tffa _ _) (bf : instruction_seq self_type tffb _ _) : instruction self_type _ (option a ::: SA) SB := IF_NONE bf bt. -Definition IF_RIGHT {a b SA SB tffa tffb} (bt : instruction self_type tffa _ _) (bf : instruction self_type tffb _ _) : instruction self_type _ (or a b ::: SA) SB := +Definition IF_RIGHT {a an b bn SA SB tffa tffb} (bt : instruction_seq self_type tffa _ _) (bf : instruction_seq self_type tffb _ _) : instruction self_type _ (or a an b bn ::: SA) SB := IF_LEFT bf bt. Definition SET_CAR {a b S} : instruction self_type Datatypes.false (pair a b ::: a ::: S) (pair a b ::: S) := - CDR ;; SWAP ;; PAIR. + Instruction_seq { CDR; SWAP; PAIR }%michelson. Definition SET_CDR {a b S} : instruction self_type Datatypes.false (pair a b ::: b ::: S) (pair a b ::: S) := - CAR ;; PAIR. + Instruction_seq { CAR; PAIR }%michelson. -Definition MAP_CAR {a1 a2 b S} (code : instruction self_type Datatypes.false (a1 ::: S) (a2 ::: S)) : +Definition MAP_CAR {a1 a2 b S} (code : instruction_seq self_type Datatypes.false (a1 ::: S) (a2 ::: S)) : instruction self_type Datatypes.false (pair a1 b ::: S) (pair a2 b ::: S) := - DUP ;; CDR ;; DIP1 (CAR ;; code) ;; SWAP ;; PAIR. + Instruction_seq { DUP; CDR; DIP1 { CAR; Instruction_seq code}; SWAP; PAIR }%michelson. -Definition MAP_CDR {a b1 b2 S} (code : instruction self_type Datatypes.false (b1 ::: pair a b1 ::: S) (b2 ::: pair a b1 ::: S)) : +Definition MAP_CDR {a b1 b2 S} (code : instruction_seq self_type Datatypes.false (b1 ::: pair a b1 ::: S) (b2 ::: pair a b1 ::: S)) : instruction self_type Datatypes.false (pair a b1 ::: S) (pair a b2 ::: S) := - DUP ;; CDR ;; code ;; SWAP ;; CAR ;; PAIR. + Instruction_seq { DUP; CDR; Instruction_seq code; SWAP; CAR; PAIR}%michelson. + +Definition UNPAPAIR {a b c S} : instruction self_type Datatypes.false (pair a (pair b c) :: S) (a ::: b ::: c ::: S) := + Instruction_seq { UNPAIR; DIP1 { UNPAIR } }. +Definition PAPAIR {a b c S} : instruction self_type Datatypes.false (a ::: b ::: c ::: S) (pair a (pair b c) :: S) := + Instruction_seq { DIP1 { PAIR }; PAIR }. -Definition UNPAPAIR {a b c S} : instruction self_type Datatypes.false (pair a (pair b c) :: S) (a ::: b ::: c ::: S) := UNPAIR ;; DIP1 UNPAIR. -Definition PAPAIR {a b c S} : instruction self_type Datatypes.false (a ::: b ::: c ::: S) (pair a (pair b c) :: S) := DIP1 PAIR;; PAIR. End macros. -End Macros. + diff --git a/src/michocoq/main.v b/src/michocoq/main.v index a9560812f7a095739e4537ef7aabf2b07222ae28..36458b113af843084c3cf7d666e5db3824c5363d 100644 --- a/src/michocoq/main.v +++ b/src/michocoq/main.v @@ -1,15 +1,18 @@ Require Import String ZArith. Require micheline_lexer micheline_parser. Require micheline2michelson typer. -Require syntax. +Require Import syntax. Require Import syntax_type. -Require dummy_contract_context. Require error_pp. Import error.Notations. +Require semantics. -Module syntax := syntax.Syntax(dummy_contract_context). -Module typer := typer.Typer(dummy_contract_context). -Import typer syntax. +Module TrivialContractContext : semantics.ContractContext. + Definition get_contract_type + (cst : smart_contract_address_constant) : Datatypes.option type := None. +End TrivialContractContext. + +Module Sem := semantics.Semantics TrivialContractContext. Section Main. Variable input : String.string. @@ -49,12 +52,13 @@ Definition contract_file_M : error.M syntax.contract_file := let! existT _ tff code := let! a := michelson_M in let i := a.(micheline2michelson.code) in - typer.type_check_instruction typer.type_instruction i _ _ in + typer.type_check_instruction_seq (typer.type_instruction_seq typer.Any) i _ _ in error.Return {| contract_file_parameter := self_type; - contract_file_storage := storage_type; - contract_tff := tff; - contract_file_code := code; |}. + contract_file_annotation := None; + contract_file_storage := storage_type; + contract_tff := tff; + contract_file_code := code; |}. Definition is_lexed := error_pp.m_pp lexed_M. @@ -74,4 +78,215 @@ Definition print_info := "Expansion: " ++ is_michelson ++ lf ++ "Type checking: " ++ type_check ++ lf)%string. +(* TZT *) + +Definition tzt_file_M := + let! x := parsed_M in + micheline2michelson.micheline2tzt_file x. + +Definition lift_opt {A B : Set} (f : A -> error.M B) (a : Datatypes.option A) : error.M (Datatypes.option B) +:= + match a with + | None => error.Return None + | Some a => + let! b := f a in + error.Return (Some b) + end. + +Definition tzt_file_typed_M := + let! file := tzt_file_M in + let! input := typer.type_stack file.(micheline2michelson.input) in + let! output := typer.type_stack file.(micheline2michelson.output) in + let! tcode := typer.type_check_instruction_seq_no_tail_fail + (typer.type_instruction_seq typer.Any) + file.(micheline2michelson.tcode) _ _ in + let! amount := + lift_opt + (fun amount => typer.type_data typer.Optimized amount mutez) + file.(micheline2michelson.amount) + in + let! balance := + lift_opt + (fun balance => typer.type_data typer.Optimized balance mutez) + file.(micheline2michelson.balance) + in + let! chain_id_ := + lift_opt + (fun chain_id_ => typer.type_data typer.Optimized chain_id_ chain_id) + file.(micheline2michelson.chain_id) + in + let! now := + lift_opt + (fun now => typer.type_data typer.Optimized now timestamp) + file.(micheline2michelson.now) + in + let! sender := + lift_opt + (fun sender => typer.type_data typer.Optimized sender address) + file.(micheline2michelson.sender) + in + let! source := + lift_opt + (fun source => typer.type_data typer.Optimized source address) + file.(micheline2michelson.source) + in + let param := file.(micheline2michelson.param) in + let! self := + lift_opt + (fun self => typer.type_data self address) + file.(micheline2michelson.self) + in + error.Return + {| + tzt_file_input := input; + tzt_file_output := output; + tzt_file_code := tcode; + tzt_file_amount := amount; + tzt_file_balance := balance; + tzt_file_chain_id := chain_id_; + tzt_file_now := now; + tzt_file_sender := sender; + tzt_file_source := source; + tzt_file_param := param; + tzt_file_self := self; + |}. + +Import Sem. + +Fixpoint pp_data {a : type} (x : data a) : String.string := + match a, x with + | Comparable_type int, z => micheline_pp.string_of_Z z + | Comparable_type nat, n => micheline_pp.string_of_Z (Z.of_N n) + | Comparable_type string, s => ("""" ++ s ++ """")%string + | Comparable_type bytes, s => ("0x" ++ s)%string + | pair a b, (x, y) => + ("Pair (" ++ pp_data x ++ ") (" ++ pp_data y ++ ")")%string + | option a, Some x => + ("Some (" ++ pp_data x ++ ")")%string + | option a, None => + "None"%string + | _, _ => "???" + end. + +Fixpoint pp_stack {A : Datatypes.list type} (s : stack A) : String.string := + match A, s with + | nil, tt => ""%string + | cons a A, (x, s) => + let s1 := pp_data x in + let s2 := pp_stack s in + ("Stack_elt (" ++ + micheline_pp.micheline_pp_single_line (michelson2micheline.michelson2micheline_type a) true ++ + ") (" ++ s1 ++ "); " ++ s2)%string + end. + +Definition tzt_file_check_M := + let! file := tzt_file_typed_M in + let output := file.(tzt_file_output) in + let input := file.(tzt_file_input) in + let amount := + match file.(tzt_file_amount) with + | None => 0 ~Mutez + | Some amount => + concrete_data_to_data mutez amount + end + in + let balance := + match file.(tzt_file_balance) with + | None => 0 ~Mutez + | Some balance => + concrete_data_to_data mutez balance + end + in + let chain_id_ := + match file.(tzt_file_chain_id) with + | None => (Mk_chain_id "chain_id"%string) + | Some chain_id_ => + concrete_data_to_data chain_id chain_id_ + end + in + let now := + match file.(tzt_file_now) with + | None => 0%Z + | Some now => + concrete_data_to_data timestamp now + end + in + let sender := + match file.(tzt_file_sender) with + | None => (Implicit (Mk_key_hash "Sender"%string)) + | Some sender => + concrete_data_to_data address sender + end + in + let source := + match file.(tzt_file_source) with + | None => (Implicit (Mk_key_hash "Source"%string)) + | Some source => + concrete_data_to_data address source + end + in + let param := + match file.(tzt_file_param) with + | None => unit + | Some ty => ty + end + in + let self := + match file.(tzt_file_self) with + | None => (Originated (syntax.Mk_smart_contract_address "Self"%string)) + | Some addr => concrete_data_to_data address addr + end + in + let dummy_hash_key (key : data key) := Mk_key_hash "key_hash"%string in + let dummy_hash (x : data bytes) := x in + let dummy_pack (a : type) (x : data a) : data bytes := "pack"%string in + let dummy_unpack (a : type) (x : data bytes) : data (option a) := None in + let dummy_check_signature key sig data := false in + let dummy_create_contract g p annot ttf delegate balance code storage := + (Mk_operation "origination"%string, + Originated (Mk_smart_contract_address "new_contract"%string)) in + let dummy_transfer_tokens p arg amount destination := + Mk_operation "transfer"%string in + let dummy_set_delegate delegate := Mk_operation "set_delegate"%string in + let proto_env : Sem.proto_env := + mk_proto_env + (Some (param, None)) + dummy_create_contract + dummy_transfer_tokens + dummy_set_delegate + balance + source + sender + self + amount + now + dummy_hash_key + dummy_pack + dummy_unpack + dummy_hash + dummy_hash + dummy_hash + dummy_check_signature + chain_id_ in + let input := Sem.stack_from_concrete input in + let! actual_output := + Sem.eval_seq proto_env file.(tzt_file_code) fuel input + in + let expected_output := Sem.stack_from_concrete output in + match stack_dec _ actual_output expected_output with + | left _ => error.Return tt + | right _ => + let expected_string := pp_stack expected_output in + let actual_string := pp_stack actual_output in + let input_string := pp_stack input in + error.Failed _ (error.Unit_test input_string expected_string actual_string) + end. + +Definition is_tzt := error_pp.m_pp tzt_file_M. + +Definition unit_test_check := error_pp.m_pp tzt_file_check_M. + +Definition print_info_tzt := + ("Unit test: " ++ unit_test_check ++ lf)%string. + End Main. diff --git a/src/michocoq/map.v b/src/michocoq/map.v index ad80bfe75de4bcd8a9c2baee355e1beb5208b480..061b5d8c463251d0c4f26ef0e6229fad914bc3b3 100644 --- a/src/michocoq/map.v +++ b/src/michocoq/map.v @@ -22,7 +22,7 @@ (* Finite maps implemented as finite sets of pairs. *) -Require set. +Require set decidable_types. Require Import error. Import error.Notations. @@ -508,6 +508,24 @@ Section map. apply set.sorted_irrel. Qed. + Lemma A_dec (a1 a2 : A) : {a1 = a2} + {a1 <> a2}. + Proof. + exact (decidable_types.comparable_decidable compare_eq_iff a1 a2). + Qed. + + Hypothesis B_dec : forall b1 b2 : B, {b1 = b2} + {b1 <> b2}. + + Lemma map_dec : decidable_types.decidable map. + Proof. + intros (l1, H1) (l2, H2). + case (decidable_types.list_dec (decidable_types.pair_dec A_dec B_dec) l1 l2). + - intro H; destruct H. + left. + f_equal. + apply set.sorted_irrel. + - intuition congruence. + Qed. + (* Interesting lemmas to use when working with maps *) Lemma map_getmem : forall k m v, diff --git a/src/michocoq/micheline2michelson.v b/src/michocoq/micheline2michelson.v index a0db094c098ff6d1fbe6daaf93b679556321dbda..4ca6c896f03cbfb8d274274afd9e5a3501dd6b8e 100644 --- a/src/michocoq/micheline2michelson.v +++ b/src/michocoq/micheline2michelson.v @@ -19,6 +19,7 @@ Definition micheline2michelson_sctype (bem : loc_micheline) : M simple_comparabl | PRIM (_, "key_hash") nil => Return key_hash | PRIM (_, "timestamp") nil => Return timestamp | PRIM (_, "address") nil => Return address + | PRIM (_, prim) _ => Failed _ (Expansion_prim b e prim) | _ => Failed _ (Expansion b e) end. @@ -35,6 +36,7 @@ Fixpoint micheline2michelson_ctype (bem : loc_micheline) : M comparable_type := end. Notation "A ;; B" := (untyped_syntax.SEQ A B) (at level 100, right associativity). +Notation "A ;;; B" := (untyped_syntax.instruction_app A B) (at level 100, right associativity). Fixpoint micheline2michelson_type (bem : loc_micheline) : M type := try (let! ty := micheline2michelson_sctype bem in Return (Comparable_type ty)) @@ -43,6 +45,7 @@ Fixpoint micheline2michelson_type (bem : loc_micheline) : M type := | Mk_loc_micheline (_, PRIM (_, "unit") nil) => Return unit | Mk_loc_micheline (_, PRIM (_, "signature") nil) => Return signature | Mk_loc_micheline (_, PRIM (_, "operation") nil) => Return operation + | Mk_loc_micheline (_, PRIM (_, "chain_id") nil) => Return chain_id | Mk_loc_micheline (_, PRIM (_, "option") (a :: nil)) => let! a := micheline2michelson_type a in Return (option a) @@ -62,7 +65,7 @@ Fixpoint micheline2michelson_type (bem : loc_micheline) : M type := | Mk_loc_micheline (_, PRIM (_, "or") (a :: b :: nil)) => let! a := micheline2michelson_type a in let! b := micheline2michelson_type b in - Return (or a b) + Return (or a None b None) | Mk_loc_micheline (_, PRIM (_, "lambda") (a :: b :: nil)) => let! a := micheline2michelson_type a in let! b := micheline2michelson_type b in @@ -75,6 +78,7 @@ Fixpoint micheline2michelson_type (bem : loc_micheline) : M type := let! a := micheline2michelson_ctype a in let! b := micheline2michelson_type b in Return (big_map a b) + | Mk_loc_micheline ((b, e), PRIM (_, prim) _) => Failed _ (Expansion_prim b e prim) | Mk_loc_micheline ((b, e), _) => Failed _ (Expansion b e) end). @@ -116,7 +120,7 @@ Fixpoint micheline2michelson_data (bem : loc_micheline) : M concrete_data := let! a := micheline2michelson_data a in Return (Some_ a) | Mk_loc_micheline (_, PRIM (_, "None") nil) => Return None_ - | Mk_loc_micheline ((b, e), PRIM s _) => Failed _ (Expansion b e) + | Mk_loc_micheline ((b, e), PRIM (_, s) _) => Failed _ (Expansion_prim b e s) end. Definition op_of_string (s : String.string) b e := @@ -127,26 +131,26 @@ Definition op_of_string (s : String.string) b e := | "GE" => Return GE | "LT" => Return LT | "GT" => Return GT - | _ => Failed _ (Expansion b e) + | _ => Failed _ (Expansion_prim b e s) end. -Definition FAIL := UNIT ;; FAILWITH. -Definition ASSERT := IF_ NOOP FAIL. +Definition FAIL := UNIT ;; FAILWITH ;; NOOP. +Definition ASSERT := (IF_ IF_bool) NOOP FAIL. Definition IF_op_of_string (s : String.string) b e bt bf := match s with | String "I" (String "F" s) => let! op := op_of_string s b e in - Return (op ;; IF_ bt bf) - | _ => Failed _ (Expansion b e) + Return (op ;; IF_ IF_bool bt bf ;; NOOP) + | _ => Failed _ (Expansion_prim b e s) end. Definition ASSERT_op_of_string (s : String.string) b e := match s with | String "A" (String "S" (String "S" (String "E" (String "R" (String "T" (String "_" s)))))) => let! op := op_of_string s b e in - Return (op ;; IF_ NOOP FAIL) - | _ => Failed _ (Expansion b e) + Return (op ;; ASSERT ;; NOOP) + | _ => Failed _ (Expansion_prim b e s) end. Definition ASSERT_NONE := IF_NONE NOOP FAIL. @@ -154,16 +158,10 @@ Definition ASSERT_SOME := IF_NONE FAIL NOOP. Definition ASSERT_LEFT := IF_LEFT NOOP FAIL. Definition ASSERT_RIGHT := IF_LEFT FAIL NOOP. -Fixpoint DIPn n code := - match n with - | 0 => code - | S n => DIP 1 (DIPn n code) - end. - Fixpoint DUP_Sn n := match n with - | 0 => DUP - | S n => DIP 1 (DUP_Sn n) ;; SWAP + | 0 => instruction_opcode DUP ;; NOOP + | S n => DIP 1 (DUP_Sn n) ;; instruction_opcode SWAP ;; NOOP end. Definition IF_SOME bt bf := IF_NONE bf bt. @@ -175,36 +173,36 @@ Inductive cadr : Set := | Cadr_CDR : cadr -> cadr | Cadr_nil : cadr. -Fixpoint micheline2michelson_cadr (x : cadr) : instruction := +Fixpoint micheline2michelson_cadr (x : cadr) : instruction_seq := match x with | Cadr_CAR x => CAR ;; micheline2michelson_cadr x | Cadr_CDR x => CDR ;; micheline2michelson_cadr x | Cadr_nil => NOOP end. -Fixpoint micheline2michelson_set_cadr (x : cadr) : instruction := +Fixpoint micheline2michelson_set_cadr (x : cadr) : instruction_seq := match x with | Cadr_CAR Cadr_nil => - CDR ;; SWAP ;; PAIR + CDR ;; SWAP ;; PAIR ;; NOOP | Cadr_CDR Cadr_nil => - CAR ;; PAIR + CAR ;; PAIR ;; NOOP | Cadr_CAR x => - DUP ;; DIP 1 (CAR;; micheline2michelson_set_cadr x) ;; CDR ;; SWAP ;; PAIR + DUP ;; DIP 1 (CAR;; micheline2michelson_set_cadr x) ;; CDR ;; SWAP ;; PAIR ;; NOOP | Cadr_CDR x => - DUP ;; DIP 1 (CDR;; micheline2michelson_set_cadr x) ;; CAR ;; PAIR + DUP ;; DIP 1 (CDR;; micheline2michelson_set_cadr x) ;; CAR ;; PAIR ;; NOOP | Cadr_nil => NOOP (* Should not happen *) end. -Fixpoint micheline2michelson_map_cadr (x : cadr) (code : instruction) : instruction := +Fixpoint micheline2michelson_map_cadr (x : cadr) (code : instruction_seq) : instruction_seq := match x with | Cadr_CAR Cadr_nil => - DUP ;; CDR ;; DIP 1 ( CAR ;; code ) ;; SWAP ;; PAIR + DUP ;; CDR ;; DIP 1 ( CAR ;; code ) ;; SWAP ;; PAIR ;; NOOP | Cadr_CDR Cadr_nil => - DUP ;; CDR ;; code ;; SWAP ;; CAR ;; PAIR + DUP ;; CDR ;; code ;;; SWAP ;; CAR ;; PAIR ;; NOOP | Cadr_CAR x => - DUP ;; DIP 1 (CAR;; micheline2michelson_map_cadr x code) ;; CDR ;; SWAP ;; PAIR + DUP ;; DIP 1 (CAR;; micheline2michelson_map_cadr x code) ;; CDR ;; SWAP ;; PAIR ;; NOOP | Cadr_CDR x => - DUP ;; DIP 1 (CDR;; micheline2michelson_map_cadr x code) ;; CAR ;; PAIR + DUP ;; DIP 1 (CDR;; micheline2michelson_map_cadr x code) ;; CAR ;; PAIR ;; NOOP | Cadr_nil => code (* Should not happen *) end. @@ -319,29 +317,30 @@ Next Obligation. lia. Defined. -Fixpoint micheline2michelson_papair (x : papair) : instruction := +Fixpoint micheline2michelson_papair (x : papair) : instruction_seq := match x with - | Papair_PAIR => PAIR - | Papair_A y => DIP 1 (micheline2michelson_papair y) ;; PAIR - | Papair_I x => micheline2michelson_papair x ;; PAIR - | Papair_P x y => micheline2michelson_papair x ;; + | Papair_PAIR => PAIR ;; NOOP + | Papair_A y => DIP 1 (micheline2michelson_papair y) ;; PAIR ;; NOOP + | Papair_I x => micheline2michelson_papair x ;;; PAIR ;; NOOP + | Papair_P x y => micheline2michelson_papair x ;;; DIP 1 (micheline2michelson_papair y) ;; - PAIR + PAIR ;; NOOP end. -Definition UNPAIR := DUP ;; CAR ;; DIP 1 CDR. +Definition UNPAIR := DUP ;; CAR ;; DIP 1 (CDR ;; NOOP) ;; NOOP. -Fixpoint micheline2michelson_unpapair (x : papair) : instruction := +Fixpoint micheline2michelson_unpapair (x : papair) : instruction_seq := match x with | Papair_PAIR => UNPAIR - | Papair_A y => UNPAIR ;; DIP 1 (micheline2michelson_unpapair y) - | Papair_I x => UNPAIR ;; micheline2michelson_unpapair x - | Papair_P x y => UNPAIR ;; + | Papair_A y => UNPAIR ;;; DIP 1 (micheline2michelson_unpapair y) ;; NOOP + | Papair_I x => UNPAIR ;;; micheline2michelson_unpapair x + | Papair_P x y => UNPAIR ;;; DIP 1 (micheline2michelson_unpapair y) ;; micheline2michelson_unpapair x end. -Definition parse_papair_full (s : String.string) (fail : exception): M instruction := +Definition parse_papair_full (s : String.string) (fail : exception) : + M instruction_seq := let! toks : Datatypes.list papair_token := lex_papair s fail in let! (l, exist _ toks2 Htoks2) := parse_papair Left toks fail (S (List.length toks)) ltac:(simpl; lia) in let! (r, exist _ toks3 Htoks3) := parse_papair Right toks2 fail (S (List.length toks2)) ltac:(simpl; lia) in @@ -354,7 +353,8 @@ Definition parse_papair_full (s : String.string) (fail : exception): M instructi | _ => Failed _ fail end. -Definition parse_unpapair_full (s : String.string) (fail : exception): M instruction := +Definition parse_unpapair_full (s : String.string) (fail : exception) + : M instruction_seq := let! toks : Datatypes.list papair_token := lex_papair s fail in let! (l, exist _ toks2 Htoks2) := parse_papair Left toks fail (S (List.length toks)) ltac:(simpl; lia) in let! (r, exist _ toks3 Htoks3) := parse_papair Right toks2 fail (S (List.length toks2)) ltac:(simpl; lia) in @@ -367,117 +367,125 @@ Definition parse_unpapair_full (s : String.string) (fail : exception): M instruc | _ => Failed _ fail end. -Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := + +Definition return_instruction (i : instruction) : M instruction_seq := + Return (i ;; NOOP). + +Definition return_opcode (op : opcode) : M instruction_seq := + return_instruction (instruction_opcode op). + +Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction_seq := match m with | Mk_loc_micheline (_, SEQ l) => - (fix micheline2michelson_instr_seq (l : Datatypes.list loc_micheline) : M instruction := + (fix micheline2michelson_instr_seq (l : Datatypes.list loc_micheline) : M instruction_seq := match l with | nil => Return NOOP - | cons i nil => micheline2michelson_instruction i - | i1 :: l => + | i1 :: i2 => let! i1 := micheline2michelson_instruction i1 in - let! i2 := micheline2michelson_instr_seq l in - Return (i1 ;; i2) + let! i2 := micheline2michelson_instr_seq i2 in + Return (i1 ;;; i2) end) l - | Mk_loc_micheline (_, PRIM (_, "FAILWITH") nil) => Return FAILWITH - | Mk_loc_micheline (_, PRIM (_, "EXEC") nil) => Return EXEC - | Mk_loc_micheline (_, PRIM (_, "APPLY") nil) => Return APPLY - | Mk_loc_micheline (_, PRIM (_, "DROP") nil) => Return (DROP 1) + | Mk_loc_micheline (_, PRIM (_, "FAILWITH") nil) => return_instruction FAILWITH + | Mk_loc_micheline (_, PRIM (_, "EXEC") nil) => return_instruction EXEC + | Mk_loc_micheline (_, PRIM (_, "APPLY") nil) => return_opcode APPLY + | Mk_loc_micheline (_, PRIM (_, "DROP") nil) => return_opcode (DROP 1) | Mk_loc_micheline (_, PRIM (_, "DROP") (Mk_loc_micheline (_, NUMBER n) :: nil)) => - Return (DROP (BinInt.Z.to_nat n)) - | Mk_loc_micheline (_, PRIM (_, "DUP") nil) => Return DUP - | Mk_loc_micheline (_, PRIM (_, "SWAP") nil) => Return SWAP - | Mk_loc_micheline (_, PRIM (_, "UNIT") nil) => Return UNIT - | Mk_loc_micheline (_, PRIM (_, "EQ") nil) => Return EQ - | Mk_loc_micheline (_, PRIM (_, "NEQ") nil) => Return NEQ - | Mk_loc_micheline (_, PRIM (_, "LT") nil) => Return LT - | Mk_loc_micheline (_, PRIM (_, "GT") nil) => Return GT - | Mk_loc_micheline (_, PRIM (_, "LE") nil) => Return LE - | Mk_loc_micheline (_, PRIM (_, "GE") nil) => Return GE - | Mk_loc_micheline (_, PRIM (_, "OR") nil) => Return OR - | Mk_loc_micheline (_, PRIM (_, "AND") nil) => Return AND - | Mk_loc_micheline (_, PRIM (_, "XOR") nil) => Return XOR - | Mk_loc_micheline (_, PRIM (_, "NOT") nil) => Return NOT - | Mk_loc_micheline (_, PRIM (_, "NEG") nil) => Return NEG - | Mk_loc_micheline (_, PRIM (_, "ABS") nil) => Return ABS - | Mk_loc_micheline (_, PRIM (_, "ISNAT") nil) => Return ISNAT - | Mk_loc_micheline (_, PRIM (_, "INT") nil) => Return INT - | Mk_loc_micheline (_, PRIM (_, "ADD") nil) => Return ADD - | Mk_loc_micheline (_, PRIM (_, "SUB") nil) => Return SUB - | Mk_loc_micheline (_, PRIM (_, "MUL") nil) => Return MUL - | Mk_loc_micheline (_, PRIM (_, "EDIV") nil) => Return EDIV - | Mk_loc_micheline (_, PRIM (_, "LSL") nil) => Return LSL - | Mk_loc_micheline (_, PRIM (_, "LSR") nil) => Return LSR - | Mk_loc_micheline (_, PRIM (_, "COMPARE") nil) => Return COMPARE - | Mk_loc_micheline (_, PRIM (_, "CONCAT") nil) => Return CONCAT - | Mk_loc_micheline (_, PRIM (_, "SIZE") nil) => Return SIZE - | Mk_loc_micheline (_, PRIM (_, "SLICE") nil) => Return SLICE - | Mk_loc_micheline (_, PRIM (_, "PAIR") nil) => Return PAIR - | Mk_loc_micheline (_, PRIM (_, "CAR") nil) => Return CAR - | Mk_loc_micheline (_, PRIM (_, "CDR") nil) => Return CDR - | Mk_loc_micheline (_, PRIM (_, "GET") nil) => Return GET - | Mk_loc_micheline (_, PRIM (_, "SOME") nil) => Return SOME + return_opcode (DROP (BinInt.Z.to_nat n)) + | Mk_loc_micheline (_, PRIM (_, "DUP") nil) => return_opcode DUP + | Mk_loc_micheline (_, PRIM (_, "SWAP") nil) => return_opcode SWAP + | Mk_loc_micheline (_, PRIM (_, "UNIT") nil) => return_opcode UNIT + | Mk_loc_micheline (_, PRIM (_, "EQ") nil) => return_opcode EQ + | Mk_loc_micheline (_, PRIM (_, "NEQ") nil) => return_opcode NEQ + | Mk_loc_micheline (_, PRIM (_, "LT") nil) => return_opcode LT + | Mk_loc_micheline (_, PRIM (_, "GT") nil) => return_opcode GT + | Mk_loc_micheline (_, PRIM (_, "LE") nil) => return_opcode LE + | Mk_loc_micheline (_, PRIM (_, "GE") nil) => return_opcode GE + | Mk_loc_micheline (_, PRIM (_, "OR") nil) => return_opcode OR + | Mk_loc_micheline (_, PRIM (_, "AND") nil) => return_opcode AND + | Mk_loc_micheline (_, PRIM (_, "XOR") nil) => return_opcode XOR + | Mk_loc_micheline (_, PRIM (_, "NOT") nil) => return_opcode NOT + | Mk_loc_micheline (_, PRIM (_, "NEG") nil) => return_opcode NEG + | Mk_loc_micheline (_, PRIM (_, "ABS") nil) => return_opcode ABS + | Mk_loc_micheline (_, PRIM (_, "ISNAT") nil) => return_opcode ISNAT + | Mk_loc_micheline (_, PRIM (_, "INT") nil) => return_opcode INT + | Mk_loc_micheline (_, PRIM (_, "ADD") nil) => return_opcode ADD + | Mk_loc_micheline (_, PRIM (_, "SUB") nil) => return_opcode SUB + | Mk_loc_micheline (_, PRIM (_, "MUL") nil) => return_opcode MUL + | Mk_loc_micheline (_, PRIM (_, "EDIV") nil) => return_opcode EDIV + | Mk_loc_micheline (_, PRIM (_, "LSL") nil) => return_opcode LSL + | Mk_loc_micheline (_, PRIM (_, "LSR") nil) => return_opcode LSR + | Mk_loc_micheline (_, PRIM (_, "COMPARE") nil) => return_opcode COMPARE + | Mk_loc_micheline (_, PRIM (_, "CONCAT") nil) => return_opcode CONCAT + | Mk_loc_micheline (_, PRIM (_, "SIZE") nil) => return_opcode SIZE + | Mk_loc_micheline (_, PRIM (_, "SLICE") nil) => return_opcode SLICE + | Mk_loc_micheline (_, PRIM (_, "PAIR") nil) => return_opcode PAIR + | Mk_loc_micheline (_, PRIM (_, "CAR") nil) => return_opcode CAR + | Mk_loc_micheline (_, PRIM (_, "CDR") nil) => return_opcode CDR + | Mk_loc_micheline (_, PRIM (_, "GET") nil) => return_opcode GET + | Mk_loc_micheline (_, PRIM (_, "SOME") nil) => return_opcode SOME | Mk_loc_micheline (_, PRIM (_, "NONE") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (NONE ty) + return_opcode (NONE ty) | Mk_loc_micheline (_, PRIM (_, "LEFT") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (LEFT ty) + return_opcode (LEFT ty) | Mk_loc_micheline (_, PRIM (_, "RIGHT") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (RIGHT ty) - | Mk_loc_micheline (_, PRIM (_, "CONS") nil) => Return CONS + return_opcode (RIGHT ty) + | Mk_loc_micheline (_, PRIM (_, "CONS") nil) => return_opcode CONS | Mk_loc_micheline (_, PRIM (_, "NIL") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (NIL ty) - | Mk_loc_micheline (_, PRIM (_, "TRANSFER_TOKENS") nil) => Return TRANSFER_TOKENS - | Mk_loc_micheline (_, PRIM (_, "SET_DELEGATE") nil) => Return SET_DELEGATE - | Mk_loc_micheline (_, PRIM (_, "BALANCE") nil) => Return BALANCE - | Mk_loc_micheline (_, PRIM (_, "ADDRESS") nil) => Return ADDRESS + return_opcode (NIL ty) + | Mk_loc_micheline (_, PRIM (_, "TRANSFER_TOKENS") nil) => + return_opcode TRANSFER_TOKENS + | Mk_loc_micheline (_, PRIM (_, "SET_DELEGATE") nil) => return_opcode SET_DELEGATE + | Mk_loc_micheline (_, PRIM (_, "BALANCE") nil) => return_opcode BALANCE + | Mk_loc_micheline (_, PRIM (_, "ADDRESS") nil) => return_opcode ADDRESS | Mk_loc_micheline (_, PRIM (_, "CONTRACT") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (CONTRACT ty) - | Mk_loc_micheline (_, PRIM (_, "SOURCE") nil) => Return SOURCE - | Mk_loc_micheline (_, PRIM (_, "SENDER") nil) => Return SENDER - | Mk_loc_micheline (_, PRIM (_, "SELF") nil) => Return SELF - | Mk_loc_micheline (_, PRIM (_, "AMOUNT") nil) => Return AMOUNT - | Mk_loc_micheline (_, PRIM (_, "IMPLICIT_ACCOUNT") nil) => Return IMPLICIT_ACCOUNT - | Mk_loc_micheline (_, PRIM (_, "NOW") nil) => Return NOW - | Mk_loc_micheline (_, PRIM (_, "PACK") nil) => Return PACK + return_opcode (CONTRACT None ty) + | Mk_loc_micheline (_, PRIM (_, "SOURCE") nil) => return_opcode SOURCE + | Mk_loc_micheline (_, PRIM (_, "SENDER") nil) => return_opcode SENDER + | Mk_loc_micheline (_, PRIM (_, "SELF") nil) => return_instruction (SELF None) + | Mk_loc_micheline (_, PRIM (_, "AMOUNT") nil) => return_opcode AMOUNT + | Mk_loc_micheline (_, PRIM (_, "IMPLICIT_ACCOUNT") nil) => return_opcode IMPLICIT_ACCOUNT + | Mk_loc_micheline (_, PRIM (_, "NOW") nil) => return_opcode NOW + | Mk_loc_micheline (_, PRIM (_, "PACK") nil) => return_opcode PACK | Mk_loc_micheline (_, PRIM (_, "UNPACK") (ty :: nil)) => let! ty := micheline2michelson_type ty in - Return (UNPACK ty) - | Mk_loc_micheline (_, PRIM (_, "HASH_KEY") nil) => Return HASH_KEY - | Mk_loc_micheline (_, PRIM (_, "BLAKE2B") nil) => Return BLAKE2B - | Mk_loc_micheline (_, PRIM (_, "SHA256") nil) => Return SHA256 - | Mk_loc_micheline (_, PRIM (_, "SHA512") nil) => Return SHA512 - | Mk_loc_micheline (_, PRIM (_, "CHECK_SIGNATURE") nil) => Return CHECK_SIGNATURE - | Mk_loc_micheline (_, PRIM (_, "MEM") nil) => Return MEM - | Mk_loc_micheline (_, PRIM (_, "UPDATE") nil) => Return UPDATE - | Mk_loc_micheline (_, PRIM (_, "CHAIN_ID") nil) => Return CHAIN_ID + return_opcode (UNPACK ty) + | Mk_loc_micheline (_, PRIM (_, "HASH_KEY") nil) => return_opcode HASH_KEY + | Mk_loc_micheline (_, PRIM (_, "BLAKE2B") nil) => return_opcode BLAKE2B + | Mk_loc_micheline (_, PRIM (_, "SHA256") nil) => return_opcode SHA256 + | Mk_loc_micheline (_, PRIM (_, "SHA512") nil) => return_opcode SHA512 + | Mk_loc_micheline (_, PRIM (_, "CHECK_SIGNATURE") nil) => + return_opcode CHECK_SIGNATURE + | Mk_loc_micheline (_, PRIM (_, "MEM") nil) => return_opcode MEM + | Mk_loc_micheline (_, PRIM (_, "UPDATE") nil) => return_opcode UPDATE + | Mk_loc_micheline (_, PRIM (_, "CHAIN_ID") nil) => return_opcode CHAIN_ID | Mk_loc_micheline (_, PRIM (_, "LOOP") (i :: nil)) => let! i := micheline2michelson_instruction i in - Return (LOOP i) + return_instruction (LOOP i) | Mk_loc_micheline (_, PRIM (_, "LOOP_LEFT") (i :: nil)) => let! i := micheline2michelson_instruction i in - Return (LOOP_LEFT i) + return_instruction (LOOP_LEFT i) | Mk_loc_micheline (_, PRIM (_, "DIP") (i :: nil)) => let! i := micheline2michelson_instruction i in - Return (DIP 1 i) + return_instruction (DIP 1 i) | Mk_loc_micheline (_, PRIM (_, "DIP") (Mk_loc_micheline (_, NUMBER n) :: i :: nil)) => let! i := micheline2michelson_instruction i in - Return (DIP (BinInt.Z.to_nat n) i) + return_instruction (DIP (BinInt.Z.to_nat n) i) | Mk_loc_micheline (_, PRIM (_, "DIG") (Mk_loc_micheline (_, NUMBER n) :: nil)) => - Return (DIG (BinInt.Z.to_nat n)) + return_opcode (DIG (BinInt.Z.to_nat n)) | Mk_loc_micheline (_, PRIM (_, "DUG") (Mk_loc_micheline (_, NUMBER n) :: nil)) => - Return (DUG (BinInt.Z.to_nat n)) + return_opcode (DUG (BinInt.Z.to_nat n)) | Mk_loc_micheline (_, PRIM (_, "ITER") (i :: nil)) => let! i := micheline2michelson_instruction i in - Return (ITER i) + return_instruction (ITER i) | Mk_loc_micheline (_, PRIM (_, "MAP") (i :: nil)) => let! i := micheline2michelson_instruction i in - Return (MAP i) + return_instruction (MAP i) | Mk_loc_micheline (_, PRIM (_, "CREATE_CONTRACT") (Mk_loc_micheline @@ -489,7 +497,7 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := let! i := micheline2michelson_instruction i in let! sty := micheline2michelson_type storage_ty in let! pty := micheline2michelson_type params_ty in - Return (CREATE_CONTRACT sty pty i) + return_instruction (CREATE_CONTRACT sty pty None i) | Mk_loc_micheline (_, PRIM (_, "CREATE_CONTRACT") (Mk_loc_micheline @@ -501,39 +509,39 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := let! i := micheline2michelson_instruction i in let! sty := micheline2michelson_type storage_ty in let! pty := micheline2michelson_type params_ty in - Return (CREATE_CONTRACT sty pty i) + return_instruction (CREATE_CONTRACT sty pty None i) | Mk_loc_micheline (_, PRIM (_, "EMPTY_SET") (cty :: nil)) => let! cty := micheline2michelson_ctype cty in - Return (EMPTY_SET cty) + return_opcode (EMPTY_SET cty) | Mk_loc_micheline (_, PRIM (_, "EMPTY_MAP") (kty :: vty :: nil)) => let! kty := micheline2michelson_ctype kty in let! vty := micheline2michelson_type vty in - Return (EMPTY_MAP kty vty) + return_opcode (EMPTY_MAP kty vty) | Mk_loc_micheline (_, PRIM (_, "EMPTY_BIG_MAP") (kty :: vty :: nil)) => let! kty := micheline2michelson_ctype kty in let! vty := micheline2michelson_type vty in - Return (EMPTY_BIG_MAP kty vty) + return_opcode (EMPTY_BIG_MAP kty vty) | Mk_loc_micheline (_, PRIM (_, "IF") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_ i1 i2) + return_instruction (IF_ IF_bool i1 i2) | Mk_loc_micheline (_, PRIM (_, "IF_NONE") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_NONE i1 i2) + return_instruction (IF_NONE i1 i2) | Mk_loc_micheline (_, PRIM (_, "IF_LEFT") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_LEFT i1 i2) + return_instruction (IF_LEFT i1 i2) | Mk_loc_micheline (_, PRIM (_, "IF_CONS") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_CONS i1 i2) + return_instruction (IF_CONS i1 i2) | Mk_loc_micheline (_, PRIM (_, "LAMBDA") (a :: b :: i :: nil)) => let! a := micheline2michelson_type a in let! b := micheline2michelson_type b in let! i := micheline2michelson_instruction i in - Return (LAMBDA a b i) + return_instruction (LAMBDA a b i) | Mk_loc_micheline (_, PRIM (_, "PUSH") (a :: v :: nil)) => let! a := micheline2michelson_type a in let! v := @@ -543,7 +551,7 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := Return (Instruction i) | _ => micheline2michelson_data v end in - Return (PUSH a v) + return_instruction (PUSH a v) | Mk_loc_micheline (_, PRIM (_, "RENAME") _) => Return NOOP | Mk_loc_micheline (_, PRIM (_, "CAST") _) => Return NOOP @@ -551,51 +559,51 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := (* Macros *) | Mk_loc_micheline ((b, e), PRIM (_, "FAIL") nil) => Return FAIL - | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT") nil) => Return ASSERT - | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_NONE") nil) => Return ASSERT_NONE - | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_SOME") nil) => Return ASSERT_SOME - | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_LEFT") nil) => Return ASSERT_LEFT - | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_RIGHT") nil) => Return ASSERT_RIGHT + | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT") nil) => return_instruction ASSERT + | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_NONE") nil) => return_instruction ASSERT_NONE + | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_SOME") nil) => return_instruction ASSERT_SOME + | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_LEFT") nil) => return_instruction ASSERT_LEFT + | Mk_loc_micheline ((b, e), PRIM (_, "ASSERT_RIGHT") nil) => return_instruction ASSERT_RIGHT | Mk_loc_micheline (_, PRIM (_, "IF_SOME") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_SOME i1 i2) + return_instruction (IF_SOME i1 i2) | Mk_loc_micheline (_, PRIM (_, "IF_RIGHT") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_RIGHT i1 i2) + return_instruction (IF_RIGHT i1 i2) | Mk_loc_micheline (_, PRIM (_, "IF_NIL") (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in - Return (IF_NIL i1 i2) + return_instruction (IF_NIL i1 i2) | Mk_loc_micheline ((b, e), PRIM (_, String "C" (String "M" (String "P" s))) nil) => let! op := op_of_string s b e in - Return (COMPARE ;; op) + Return (COMPARE ;; op ;; NOOP) | Mk_loc_micheline ((b, e), PRIM (_, String "I" (String "F" (String "C" (String "M" (String "P" s))))) (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in let! op := op_of_string s b e in - Return (COMPARE ;; op ;; IF_ i1 i2) + Return (COMPARE ;; op ;; IF_ IF_bool i1 i2 ;; NOOP) | Mk_loc_micheline ((b, e), PRIM (_, String "I" (String "F" s)) (i1 :: i2 :: nil)) => let! i1 := micheline2michelson_instruction i1 in let! i2 := micheline2michelson_instruction i2 in let! op := op_of_string s b e in - Return (op ;; IF_ i1 i2) + Return (op ;; IF_ IF_bool i1 i2 ;; NOOP) | Mk_loc_micheline ((b, e), PRIM (_, String "A" (String "S" (String "S" (String "E" (String "R" (String "T" (String "_" (String "C" (String "M" (String "P" s)))))))))) nil) => let! op := op_of_string s b e in - Return (COMPARE;; op ;; IF_ NOOP FAIL) + Return (COMPARE ;; op ;; IF_ IF_bool NOOP FAIL ;; NOOP) | Mk_loc_micheline ((b, e), PRIM (_, String "A" (String "S" (String "S" (String "E" (String "R" (String "T" (String "_" s))))))) nil) => let! op := op_of_string s b e in - Return (op ;; IF_ NOOP FAIL) + Return (op ;; IF_ IF_bool NOOP FAIL ;; NOOP) | Mk_loc_micheline ((b, e), PRIM (_, "CR") nil) => Failed _ (Expansion_prim b e "CR") @@ -667,12 +675,12 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := end in if is_diip s then let! a := micheline2michelson_instruction a in - Return (DIPn (String.length s) a) + return_instruction (DIP (String.length s) a) else Failed _ (Expansion_prim b e (String "D" (String "I" s))) | Mk_loc_micheline ((b, e), PRIM (_, "DUP") (Mk_loc_micheline (_, NUMBER n) :: nil)) => match BinInt.Z.to_nat n with | S n => Return (DUP_Sn n) - | O => Failed _ (Expansion b e) + | O => Failed _ (Expansion_prim b e "DUP") end | Mk_loc_micheline ((b, e), PRIM (_, String "D" (String "U" (String "U" s))) nil) => let is_duup := fix is_duup s := @@ -701,17 +709,20 @@ Fixpoint micheline2michelson_instruction (m : loc_micheline) : M instruction := | Mk_loc_micheline ((b, e), _) => Failed _ (Expansion b e) end. + +(* Full Michelson files *) + Record untyped_michelson_file := Mk_untyped_michelson_file { parameter : type; storage : type; - code : instruction }. + code : instruction_seq }. Record untyped_michelson_file_opt := Mk_untyped_michelson_file_opt { parameter_opt : Datatypes.option type; storage_opt : Datatypes.option type; - code_opt : Datatypes.option instruction }. + code_opt : Datatypes.option instruction_seq }. Definition read_parameter (ty : type) (f : untyped_michelson_file_opt) := match f.(parameter_opt) with @@ -729,7 +740,7 @@ Definition read_storage (ty : type) (f : untyped_michelson_file_opt) := | Some _ => Failed _ Parsing end. -Definition read_code (c : instruction) (f : untyped_michelson_file_opt) := +Definition read_code (c : instruction_seq) (f : untyped_michelson_file_opt) := match f.(code_opt) with | None => Return {| parameter_opt := f.(parameter_opt); storage_opt := f.(storage_opt); @@ -768,3 +779,331 @@ Definition micheline2michelson_file (m : Datatypes.list loc_micheline) : M untyp | _, _, _ => Failed _ Parsing end. +(* TZT unit test files *) + +Definition concrete_stack := Datatypes.list (type * concrete_data). + +Fixpoint micheline2michelson_stack (bem : loc_micheline) : M concrete_stack := + match bem with + | Mk_loc_micheline (_, SEQ l) => + (fix micheline2michelson_stack_list (l : Datatypes.list loc_micheline) : M concrete_stack := + match l with + | nil => Return nil + | (Mk_loc_micheline (_, PRIM (_, "Stack_elt") (mty :: m :: nil))) :: l => + let! ty := micheline2michelson_type mty in + let! d := + match ty with + | lambda _ _ => + let! i := micheline2michelson_instruction m in + Return (Instruction i) + | _ => micheline2michelson_data m + end in + let! l := micheline2michelson_stack_list l in + Return ((ty, d) :: l) + | (Mk_loc_micheline ((b, e), PRIM (_, prim) _)) :: _ => Failed _ (Expansion_prim b e prim) + | (Mk_loc_micheline ((b, e), _)) :: _ => Failed _ (Expansion b e) + end + ) l + | Mk_loc_micheline ((b, e), PRIM (_, prim) _) => Failed _ (Expansion_prim b e prim) + | Mk_loc_micheline ((b, e), _) => Failed _ (Expansion b e) + end. + +Record untyped_tzt_file := + Mk_untyped_tzt_file + { input : concrete_stack; + tcode : instruction_seq; + output : concrete_stack; + amount : Datatypes.option concrete_data; + balance : Datatypes.option concrete_data; + chain_id : Datatypes.option concrete_data; + now : Datatypes.option concrete_data; + sender : Datatypes.option concrete_data; + source : Datatypes.option concrete_data; + param : Datatypes.option type; + self : Datatypes.option concrete_data; + }. + +Record untyped_tzt_file_opt := + Mk_untyped_tzt_file_opt + { input_opt : Datatypes.option concrete_stack; + tcode_opt : Datatypes.option instruction_seq; + output_opt : Datatypes.option concrete_stack; + amount_opt : Datatypes.option concrete_data; + balance_opt : Datatypes.option concrete_data; + chain_id_opt : Datatypes.option concrete_data; + now_opt : Datatypes.option concrete_data; + sender_opt : Datatypes.option concrete_data; + source_opt : Datatypes.option concrete_data; + param_opt : Datatypes.option type; + self_opt : Datatypes.option concrete_data; + }. + +Definition read_tzt_input (s : concrete_stack) (f : untyped_tzt_file_opt) := + match f.(input_opt) with + | None => Return {| input_opt := Some s; + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated input field") + end. + +Definition read_tzt_code (c : instruction_seq) (f : untyped_tzt_file_opt) := + match f.(tcode_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := Some c; + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated code field") + end. + +Definition read_tzt_output (s : concrete_stack) (f : untyped_tzt_file_opt) := + match f.(output_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := Some s; + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated output field") + end. + +Definition read_tzt_amount (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(amount_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := Some s; + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some s' => Failed _ (Debug "duplicated amount field") + end. + +Definition read_tzt_balance (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(balance_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := Some s; + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated balance field") + end. + +Definition read_tzt_chain_id (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(chain_id_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := Some s; + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated chain_id field") + end. + +Definition read_tzt_now (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(now_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := Some s; + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated now field") + end. + +Definition read_tzt_sender (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(sender_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := Some s; + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated sender field") + end. + + +Definition read_tzt_source (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(source_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := Some s; + param_opt := f.(param_opt); + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated source field") + end. + +Definition read_tzt_param (s : type) (f : untyped_tzt_file_opt) := + match f.(param_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := Some s; + self_opt := f.(self_opt); + |} + | Some _ => Failed _ (Debug "duplicated param field") + end. + +Definition read_tzt_self (s : concrete_data) (f : untyped_tzt_file_opt) := + match f.(self_opt) with + | None => Return {| input_opt := f.(input_opt); + tcode_opt := f.(tcode_opt); + output_opt := f.(output_opt); + amount_opt := f.(amount_opt); + balance_opt := f.(balance_opt); + chain_id_opt := f.(chain_id_opt); + now_opt := f.(now_opt); + sender_opt := f.(sender_opt); + source_opt := f.(source_opt); + param_opt := f.(param_opt); + self_opt := Some s; + |} + | Some _ => Failed _ (Debug "duplicated self field") + end. + +Definition micheline2tzt_file (m : Datatypes.list loc_micheline) : M untyped_tzt_file := + let l := + match m with + | Mk_loc_micheline (_, SEQ l) :: nil => l + | l => l + end + in + let! a := + error.list_fold_left + (fun (a : untyped_tzt_file_opt) (lm : loc_micheline) => + let 'Mk_loc_micheline (b, e, m) := lm in + match m with + | PRIM (_, _, "input") (cons input nil) => + let! input := micheline2michelson_stack input in + read_tzt_input input a + | PRIM (_, _, "code") (cons code nil) => + let! c := micheline2michelson_instruction code in + read_tzt_code c a + | PRIM (_, _, "output") (cons output nil) => + let! output := micheline2michelson_stack output in + read_tzt_output output a + | PRIM (_, _, "amount") (cons amount nil) => + let! amount := micheline2michelson_data amount in + read_tzt_amount amount a + | PRIM (_, _, "balance") (cons balance nil) => + let! balance := micheline2michelson_data balance in + read_tzt_balance balance a + | PRIM (_, _, "chain_id") (cons chain_id nil) => + let! chain_id := micheline2michelson_data chain_id in + read_tzt_chain_id chain_id a + | PRIM (_, _, "now") (cons now nil) => + let! now := micheline2michelson_data now in + read_tzt_now now a + | PRIM (_, _, "sender") (cons sender nil) => + let! sender := micheline2michelson_data sender in + read_tzt_sender sender a + | PRIM (_, _, "source") (cons source nil) => + let! source := micheline2michelson_data source in + read_tzt_source source a + | PRIM (_, _, "parameter") (cons param nil) => + let! param := micheline2michelson_type param in + read_tzt_param param a + | PRIM (_, _, "self") (cons self nil) => + let! self := micheline2michelson_data self in + read_tzt_self self a + | PRIM (_, _, prim) _ => + Failed _ (Expansion_prim b e prim) + | _ => Failed _ (Expansion b e) + end) + l + {| + input_opt := None; + tcode_opt := None; + output_opt := None; + amount_opt := None; + balance_opt := None; + chain_id_opt := None; + now_opt := None; + sender_opt := None; + source_opt := None; + param_opt := None; + self_opt := None; + |} in + match a.(input_opt), a.(tcode_opt), a.(output_opt) with + | Some input, Some code, Some output => + Return + {| input := input; + tcode := code; + output := output; + amount := a.(amount_opt); + balance := a.(balance_opt); + chain_id := a.(chain_id_opt); + now := a.(now_opt); + sender := a.(sender_opt); + source := a.(source_opt); + param := a.(param_opt); + self := a.(self_opt); + |} + | _, _, _ => Failed _ (Debug "missing a mandatory field") + end. + diff --git a/src/michocoq/micheline_lexer.v b/src/michocoq/micheline_lexer.v index b6ba2aa7160348aa324a1c1882618c51cdac694b..0e2d3fabe4cc601d735c9df51dec378bc79ce853 100644 --- a/src/michocoq/micheline_lexer.v +++ b/src/michocoq/micheline_lexer.v @@ -1,5 +1,5 @@ Require Import List String Ascii ZArith. -Require error micheline_parser. +Require error micheline_parser bytes_repr. Require Import micheline_tokens location. Import error.Notations. @@ -72,6 +72,12 @@ Definition Z_of_char (c : ascii) (acc : Z) : Z := Definition string_snoc s c := (s ++ String c "")%string. +Definition bytes_of_string loc (s : string) := + match bytes_repr.of_string s with + | Some bs => error.Return bs + | None => error.Failed _ (error.Lexing loc) + end. + Fixpoint lex_micheline (input : string) (loc : location) : error.M (list (location.location * location.location * token)) := match input with | String first_char input => @@ -130,9 +136,12 @@ Fixpoint lex_micheline (input : string) (loc : location) : error.M (list (locati let loc := location_incr loc in lex_micheline_bytes s (string_snoc acc c) start loc else - let! l := lex_micheline input loc in - error.Return (cons (start, loc, BYTES acc) l) - | EmptyString => error.Return (cons (start, loc, BYTES acc) nil) + let! l := lex_micheline input loc in + let! bs := bytes_of_string start acc in + error.Return (cons (start, loc, BYTES bs) l) + | EmptyString => + let! bs := bytes_of_string start acc in + error.Return (cons (start, loc, BYTES bs) nil) end) s EmptyString loc (location_incr (location_incr loc)) | String c s => if char_is_num c then error.Failed _ (error.Lexing loc) diff --git a/src/michocoq/micheline_pp.v b/src/michocoq/micheline_pp.v index cc644572455710b9cc014c7ae1b8d83c6ae201ac..9971f02f8cd39c76ddb0785e8a7a41feffcea062 100644 --- a/src/michocoq/micheline_pp.v +++ b/src/michocoq/micheline_pp.v @@ -23,7 +23,7 @@ Fixpoint micheline_length (mich : loc_micheline) (in_seq : bool) := match m with | NUMBER z => String.length (string_of_Z z) | STR s => 2 + String.length s - | BYTES s => 2 + String.length s + | BYTES s => 2 + 2 * String.length s | SEQ nil => 2 | SEQ es => fold_left (fun acc m => 2 + micheline_length m true + acc) es 0 | PRIM (_, _, s) nil => String.length s @@ -37,7 +37,7 @@ Fixpoint micheline_pp_single_line (mich : loc_micheline) (in_seq : bool) := match m with | NUMBER z => string_of_Z z | STR s => """" ++ s ++ """" - | BYTES s => "0x" ++ s + | BYTES bs => "0x" ++ (bytes_repr.to_string bs) | SEQ es => "{" ++ String.concat "; " (map (fun m => micheline_pp_single_line m true) es) ++ "}" | PRIM (_, _, s) nil => s | PRIM (_, _, s) es => @@ -53,7 +53,7 @@ Fixpoint micheline_pp (mich : loc_micheline) (indent : nat) (in_seq : bool) match mich with | Mk_loc_micheline (_, _, NUMBER z) => (string_of_Z z) | Mk_loc_micheline (_, _, STR s) => """"++s++"""" - | Mk_loc_micheline (_, _, BYTES s) => "0x"++s + | Mk_loc_micheline (_, _, BYTES bs) => "0x"++bytes_repr.to_string bs | Mk_loc_micheline (_, _, SEQ es) => let indent_space := (make_string " " indent) in let separator := (";" ++ lf ++ indent_space ++ " ") in diff --git a/src/michocoq/michelson2micheline.v b/src/michocoq/michelson2micheline.v index cb001fc48aa43a0b34113fd17fd1d37818e36ef3..13ec287b3eedf1345842b0a95f6379eea3ea6bfb 100644 --- a/src/michocoq/michelson2micheline.v +++ b/src/michocoq/michelson2micheline.v @@ -37,6 +37,15 @@ Fixpoint michelson2micheline_ctype (ct: comparable_type) : loc_micheline := [michelson2micheline_sctype sct; michelson2micheline_ctype ct] end. +Definition michelson2micheline_atype michelson2micheline_type (t : type) (an : annot_o) : loc_micheline := + match an, michelson2micheline_type t with + | None, m => m + | Some an, Mk_loc_micheline (loca, locb, (PRIM (loc1, loc2, p) l)) => + Mk_loc_micheline (loca, locb, (PRIM (loc1, loc2, p) (dummy_prim an nil :: l))) + | Some an, m => (* Cannot happen *) + dummy_prim "strange_annotated_type" nil + end. + Fixpoint michelson2micheline_type (t : type) : loc_micheline := match t with | Comparable_type ct => michelson2micheline_sctype ct @@ -50,8 +59,8 @@ Fixpoint michelson2micheline_type (t : type) : loc_micheline := | contract t' => dummy_prim "contract" [michelson2micheline_type t'] | pair t1 t2 => dummy_prim "pair" [michelson2micheline_type t1; michelson2micheline_type t2] - | or t1 t2 => - dummy_prim "or" [michelson2micheline_type t1; michelson2micheline_type t2] + | or t1 n1 t2 n2 => + dummy_prim "or" [michelson2micheline_atype michelson2micheline_type t1 n1; michelson2micheline_atype michelson2micheline_type t2 n2] | lambda t1 t2 => dummy_prim "lambda" [michelson2micheline_type t1; michelson2micheline_type t2] | map ct1 t2 => @@ -61,7 +70,7 @@ Fixpoint michelson2micheline_type (t : type) : loc_micheline := | chain_id => dummy_prim "chain_id" [] end. -Fixpoint michelson2micheline_data (d : concrete_data) : loc_micheline := +Fixpoint michelson2micheline_concrete_data (d : concrete_data) : loc_micheline := match d with | Int_constant z => dummy_mich (NUMBER z) | String_constant s => dummy_mich (STR s) @@ -70,36 +79,19 @@ Fixpoint michelson2micheline_data (d : concrete_data) : loc_micheline := | True_ => dummy_prim "True" [] | False_ => dummy_prim "False" [] | Pair a b => - dummy_prim "Pair" [michelson2micheline_data a; michelson2micheline_data b] - | Left a => dummy_prim "Left" [michelson2micheline_data a] - | Right a => dummy_prim "Right" [michelson2micheline_data a] - | Some_ a => dummy_prim "Some" [michelson2micheline_data a] + dummy_prim "Pair" [michelson2micheline_concrete_data a; michelson2micheline_concrete_data b] + | Left a => dummy_prim "Left" [michelson2micheline_concrete_data a] + | Right a => dummy_prim "Right" [michelson2micheline_concrete_data a] + | Some_ a => dummy_prim "Some" [michelson2micheline_concrete_data a] | None_ => dummy_prim "None" [] | Elt a b => - dummy_prim "Elt" [michelson2micheline_data a; michelson2micheline_data b] - | Concrete_seq s => dummy_mich (SEQ (List.map michelson2micheline_data s)) + dummy_prim "Elt" [michelson2micheline_concrete_data a; michelson2micheline_concrete_data b] + | Concrete_seq s => dummy_mich (SEQ (List.map michelson2micheline_concrete_data s)) | Instruction _ => dummy_prim "NOOP" [] (* Should never occur *) end. -Fixpoint michelson2micheline_ins (i : instruction) : loc_micheline := - match i with - | NOOP => dummy_mich (SEQ []) - | untyped_syntax.SEQ i1 i2 => - let m1 := michelson2micheline_ins i1 in - let m2 := michelson2micheline_ins i2 in - let ls1 := - match m1 with - | Mk_loc_micheline (_, _, (SEQ ls1)) => ls1 - | _ => [m1]%list - end in - let ls2 := - match m2 with - | Mk_loc_micheline (_, _, (SEQ ls2)) => ls2 - | _ => [m2]%list - end in - dummy_mich (SEQ (List.app ls1 ls2)) - | FAILWITH => dummy_prim "FAILWITH" [] - | EXEC => dummy_prim "EXEC" [] +Definition michelson2micheline_opcode (o : opcode) : loc_micheline := + match o with | APPLY => dummy_prim "APPLY" [] | DUP => dummy_prim "DUP" [] | SWAP => dummy_prim "SWAP" [] @@ -145,20 +137,17 @@ Fixpoint michelson2micheline_ins (i : instruction) : loc_micheline := | EMPTY_BIG_MAP ct t => dummy_prim "EMPTY_BIG_MAP" [michelson2micheline_ctype ct; michelson2micheline_type t] - | MEM => dummy_prim "MEM" nil - | UPDATE => dummy_prim "UPDATE" nil - | CREATE_CONTRACT t1 t2 i => dummy_prim "CREATE_CONTRACT" - [michelson2micheline_type t1; - michelson2micheline_type t2; - dummy_seq (michelson2micheline_ins i)] + | MEM => dummy_prim "MEM" [] + | UPDATE => dummy_prim "UPDATE" [] | TRANSFER_TOKENS => dummy_prim "TRANSFER_TOKENS" [] | SET_DELEGATE => dummy_prim "SET_DELEGATE" [] | BALANCE => dummy_prim "BALANCE" [] | ADDRESS => dummy_prim "ADDRESS" [] - | CONTRACT t => dummy_prim "CONTRACT" [michelson2micheline_type t] + | CONTRACT None t => dummy_prim "CONTRACT" [michelson2micheline_type t] + | CONTRACT (Some an) t => + dummy_prim "CONTRACT" [dummy_prim an []; michelson2micheline_type t] | SOURCE => dummy_prim "SOURCE" [] | SENDER => dummy_prim "SENDER" [] - | SELF => dummy_prim "SELF" [] | AMOUNT => dummy_prim "AMOUNT" [] | IMPLICIT_ACCOUNT => dummy_prim "IMPLICIT_ACCOUNT" [] | NOW => dummy_prim "NOW" [] @@ -169,44 +158,64 @@ Fixpoint michelson2micheline_ins (i : instruction) : loc_micheline := | SHA256 => dummy_prim "SHA256" [] | SHA512 => dummy_prim "SHA512" [] | CHECK_SIGNATURE => dummy_prim "CHECK_SIGNATURE" [] - | IF_ i1 i2 => - dummy_prim "IF" [dummy_seq (michelson2micheline_ins i1); - dummy_seq (michelson2micheline_ins i2)] - | IF_NONE i1 i2 => - dummy_prim "IF_NONE" [dummy_seq (michelson2micheline_ins i1); - dummy_seq (michelson2micheline_ins i2)] - | IF_LEFT i1 i2 => - dummy_prim "IF_LEFT" [dummy_seq (michelson2micheline_ins i1); - dummy_seq (michelson2micheline_ins i2)] - | IF_CONS i1 i2 => - dummy_prim "IF_CONS" [dummy_seq (michelson2micheline_ins i1); - dummy_seq (michelson2micheline_ins i2)] - | LOOP i => - dummy_prim "LOOP" [dummy_seq (michelson2micheline_ins i)] - | LOOP_LEFT i => - dummy_prim "LOOP_LEFT" [dummy_seq (michelson2micheline_ins i)] + | DIG n => dummy_prim "DIG" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] + | DUG n => dummy_prim "DUG" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] + | DROP n => dummy_prim "DROP" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] + | CHAIN_ID => dummy_prim "CHAIN_ID" [] + end. + +Fixpoint michelson2micheline_instruction (i : instruction) : loc_micheline := + match i with + | Instruction_seq i => + dummy_mich (SEQ (michelson2micheline_ins_seq i)) + | FAILWITH => dummy_prim "FAILWITH" [] + | CREATE_CONTRACT t1 t2 an i => dummy_prim "CREATE_CONTRACT" + [michelson2micheline_type t1; + michelson2micheline_atype + michelson2micheline_type t2 an; + dummy_mich (SEQ (michelson2micheline_ins_seq i))] + | IF_ f i1 i2 => + let s := match f with + | IF_bool => "IF" + | IF_or => "IF_LEFT" + | IF_option => "IF_NONE" + | IF_list => "IF_CONS" + end in + dummy_prim s [dummy_mich (SEQ (michelson2micheline_ins_seq i1)); + dummy_mich (SEQ (michelson2micheline_ins_seq i2))] + | LOOP_ f i => + let s := match f with LOOP_bool => "LOOP" | LOOP_or => "LOOP_LEFT" end in + dummy_prim s [dummy_mich (SEQ (michelson2micheline_ins_seq i))] | ITER i => - dummy_prim "ITER" [dummy_seq (michelson2micheline_ins i)] + dummy_prim "ITER" [dummy_mich (SEQ (michelson2micheline_ins_seq i))] | MAP i => - dummy_prim "MAP" [dummy_seq (michelson2micheline_ins i)] + dummy_prim "MAP" [dummy_mich (SEQ (michelson2micheline_ins_seq i))] | PUSH t d => let t' := (michelson2micheline_type t) in match d with | Instruction d' => - dummy_prim "PUSH" [t'; dummy_seq (michelson2micheline_ins d')] + dummy_prim "PUSH" [t'; dummy_mich (SEQ (michelson2micheline_ins_seq d'))] | _ => - dummy_prim "PUSH" [t'; michelson2micheline_data d] + dummy_prim "PUSH" [t'; michelson2micheline_concrete_data d] end | LAMBDA t1 t2 i => dummy_prim "LAMBDA" [ michelson2micheline_type t1; michelson2micheline_type t2; - dummy_seq (michelson2micheline_ins i)] - | DIG n => dummy_prim "DIG" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] - | DUG n => dummy_prim "DUG" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] - | DROP n => dummy_prim "DROP" [dummy_mich (NUMBER (BinInt.Z.of_nat n))] + dummy_mich (SEQ (michelson2micheline_ins_seq i))] | DIP n i => dummy_prim "DIP" [dummy_mich (NUMBER (BinInt.Z.of_nat n)); - dummy_seq (michelson2micheline_ins i)] - | CHAIN_ID => dummy_prim "CHAIN_ID" [] + dummy_mich (SEQ (michelson2micheline_ins_seq i))] + | SELF None => dummy_prim "SELF" [] + | SELF (Some an) => dummy_prim "SELF" [dummy_prim an []] + | EXEC => dummy_prim "EXEC" [] + | instruction_opcode o => + michelson2micheline_opcode o + end +with +michelson2micheline_ins_seq (i : instruction_seq) : Datatypes.list loc_micheline := + match i with + | NOOP => [] + | untyped_syntax.SEQ i1 i2 => + michelson2micheline_instruction i1 :: michelson2micheline_ins_seq i2 end. Definition eqb_ascii (a b : ascii) : Datatypes.bool := @@ -223,6 +232,3 @@ Fixpoint eqb_string (s1 s2 : String.string) : Datatypes.bool := | String a1 s1, String a2 s2 => andb (eqb_ascii a1 a2) (eqb_string s1 s2) | _, _ => false end. - -Definition michelson2micheline_instruction (i : instruction) : loc_micheline := - dummy_seq (michelson2micheline_ins i). diff --git a/src/michocoq/of_ocaml/README.org b/src/michocoq/of_ocaml/README.org new file mode 100644 index 0000000000000000000000000000000000000000..f88d0e60770e9cdd66601ccbe0443edb3c073945 --- /dev/null +++ b/src/michocoq/of_ocaml/README.org @@ -0,0 +1,12 @@ +#+Title: Comparison to the Tezos implementation + +This folder contains proofs comparing the Mi-Cho-Coq formalization to the Tezos +implementation. We use [[https://github.com/clarus/coq-of-ocaml][coq-of-ocaml]] +to convert large chunks of the Tezos OCaml code to Coq. We amend this imported +code by hand and then make some proofs. + +* What do we compare + +- comparable types (bijection); +- types (injection); +- syntax (partial injection). diff --git a/src/michocoq/of_ocaml/script_typed_ir_ml.v b/src/michocoq/of_ocaml/script_typed_ir_ml.v new file mode 100644 index 0000000000000000000000000000000000000000..712fad35a62ee3cc9535748587aacc34f6fa7212 --- /dev/null +++ b/src/michocoq/of_ocaml/script_typed_ir_ml.v @@ -0,0 +1,786 @@ +(** File imported from the Tezos protocol Babylon in the file + ` proto_alpha/lib_protocol/script_typed_ir.ml`. We did the following changes: + * add dependencies as axioms at the beginning of the file; + * comment what is not supported: + * cases generating positivity checking errors; + * set and map first-class modules. + In particular we do not support instructions related to lambdas. +*) +Require Import Coq.Strings.String. +Require Import ZArith. + +Local Open Scope type_scope. + +Module Tezos_protocol_environment_alpha. + Module Environment. + Module Chain_id. + Parameter t : Type. + End Chain_id. + + Module MBytes. + Parameter t : Type. + End MBytes. + + Module Z. + Parameter t : Type. + End Z. + End Environment. +End Tezos_protocol_environment_alpha. + +Module Tezos_raw_protocol_alpha. + Module Alpha_context. + Module Contract. + Parameter big_map_diff : Type. + Parameter t : Type. + End Contract. + + Module Script. + Parameter location : Type. + Parameter node : Type. + End Script. + + Module Script_int. + Parameter n : Type. + Parameter n_sample : n. + Parameter num : Type -> Type. + Parameter num_make : forall {A : Type}, A -> num A. + Parameter z : Type. + Parameter z_sample : z. + End Script_int. + + Module Script_timestamp. + Parameter t : Type. + End Script_timestamp. + + Module Tez. + Parameter t : Type. + End Tez. + + Parameter packed_internal_operation : Type. + Parameter public_key : Type. + Parameter public_key_hash : Type. + Parameter signature : Type. + End Alpha_context. +End Tezos_raw_protocol_alpha. + +Parameter var_annot : Type. + +Parameter type_annot : Type. + +Parameter field_annot : Type. + +Definition address := + Tezos_raw_protocol_alpha.Alpha_context.Contract.t * string. + +Definition pair (a b : Type) := a * b. + +Inductive union (a b : Type) : Type := +| L : a -> union a b +| R : b -> union a b. + +Arguments L {_ _}. +Arguments R {_ _}. + +Inductive comb : Type := +| Comb : comb. + +Inductive leaf : Type := +| Leaf : leaf. + +Inductive comparable_struct : forall (_ _ : Type), Type := +| Int_key : forall {A : Type}, (option type_annot) -> + comparable_struct + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) A +| Nat_key : forall {A : Type}, (option type_annot) -> + comparable_struct + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) A +| String_key : forall {A : Type}, (option type_annot) -> + comparable_struct string A +| Bytes_key : forall {A : Type}, (option type_annot) -> + comparable_struct Tezos_protocol_environment_alpha.Environment.MBytes.t A +| Mutez_key : forall {A : Type}, (option type_annot) -> + comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Tez.t A +| Bool_key : forall {A : Type}, (option type_annot) -> comparable_struct bool A +| Key_hash_key : forall {A : Type}, (option type_annot) -> + comparable_struct Tezos_raw_protocol_alpha.Alpha_context.public_key_hash A +| Timestamp_key : forall {A : Type}, (option type_annot) -> + comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t A +| Address_key : forall {A : Type}, (option type_annot) -> + comparable_struct address A +| Pair_key : forall {C a b : Type}, + ((comparable_struct a leaf) * (option field_annot)) -> + ((comparable_struct b C) * (option field_annot)) -> (option type_annot) -> + comparable_struct (pair a b) comb. + +Definition comparable_ty (a : Type) := comparable_struct a comb. + +(*Module Boxed_set. + Record signature {elt OPS_t : Type} := { + elt := elt; + elt_ty : comparable_ty elt; + OPS : S.SET.signature elt OPS_t; + boxed : OPS.(Tezos_protocol_environment_alpha.Environment.SET.S.t); + size : Z; + }. + Arguments signature : clear implicits. +End Boxed_set. + +Definition set (elt : Type) := {OPS_t : _ & Boxed_set.signature elt OPS_t}.*) + +Parameter set : Type -> Type. + +(*Module Boxed_map. + Record signature {key value OPS_t : Type} := { + key := key; + value := value; + key_ty : comparable_ty key; + OPS : S.MAP.signature key OPS_t; + boxed : (OPS.(Tezos_protocol_environment_alpha.Environment.MAP.S.t) value) + * Z; + }. + Arguments signature : clear implicits. +End Boxed_map. + +Definition map (key value : Type) := + {OPS_t : _ & Boxed_map.signature key value OPS_t}.*) + +Parameter map : Type -> Type -> Type. + +Definition operation := + Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation * + (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff). + +Reserved Notation "'script". +Reserved Notation "'end_of_stack". +Reserved Notation "'typed_contract". +Reserved Notation "'big_map". +Reserved Notation "'descr". + +Record descr_skeleton {loc bef aft instr : Type} := { + loc : loc; + bef : bef; + aft : aft; + instr_ : instr }. +Arguments descr_skeleton : clear implicits. + +Record big_map_skeleton {id diff key_type value_type : Type} := { + id : id; + diff : diff; + key_type : key_type; + value_type : value_type }. +Arguments big_map_skeleton : clear implicits. + +Record script_skeleton {code arg_type storage storage_type root_name : Type} := + { + code : code; + arg_type : arg_type; + storage : storage; + storage_type : storage_type; + root_name : root_name }. +Arguments script_skeleton : clear implicits. + +(*Inductive lambda : forall (arg ret : Type), Type := +| Lam : forall (arg ret : Type), ('descr (arg * 'end_of_stack) (ret * 'end_of_stack)) -> +Tezos_raw_protocol_alpha.Alpha_context.Script.node -> lambda arg ret*) + +Parameter lambda : forall (arg ret : Type), Type. + +Polymorphic Inductive Ty : forall (ty : Type), Type := +| Unit_t : (option type_annot) -> Ty unit +| Int_t : (option type_annot) -> + Ty + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) +| Nat_t : (option type_annot) -> + Ty + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) +| Signature_t : (option type_annot) -> + Ty Tezos_raw_protocol_alpha.Alpha_context.signature +| String_t : (option type_annot) -> Ty string +| Bytes_t : (option type_annot) -> + Ty Tezos_protocol_environment_alpha.Environment.MBytes.t +| Mutez_t : (option type_annot) -> + Ty Tezos_raw_protocol_alpha.Alpha_context.Tez.t +| Key_hash_t : (option type_annot) -> + Ty Tezos_raw_protocol_alpha.Alpha_context.public_key_hash +| Key_t : (option type_annot) -> + Ty Tezos_raw_protocol_alpha.Alpha_context.public_key +| Timestamp_t : (option type_annot) -> + Ty Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t +| Address_t : (option type_annot) -> Ty address +| Bool_t : (option type_annot) -> Ty bool +| Pair_t : forall {a b : Type}, + ((Ty a) * (option field_annot) * (option var_annot)) -> + ((Ty b) * (option field_annot) * (option var_annot)) -> (option type_annot) -> + bool -> Ty (pair a b) +| Union_t : forall {a b : Type}, ((Ty a) * (option field_annot)) -> + ((Ty b) * (option field_annot)) -> (option type_annot) -> bool -> + Ty (union a b) +| Lambda_t : forall {arg ret : Type}, (Ty arg) -> (Ty ret) -> + (option type_annot) -> Ty (lambda arg ret) +| Option_t : forall {v : Type}, (Ty v) -> (option type_annot) -> bool -> + Ty (option v) +| List_t : forall {v : Type}, (Ty v) -> (option type_annot) -> bool -> + Ty (list v) +| Set_t : forall {v : Type}, (comparable_ty v) -> (option type_annot) -> + Ty (set v) +| Map_t : forall {k v : Type}, (comparable_ty k) -> (Ty v) -> + (option type_annot) -> bool -> Ty (map k v) +(*| Big_map_t : forall {k v : Type}, (comparable_ty k) -> (Ty v) -> + (option type_annot) -> Ty ('big_map k v)*) +(*| Contract_t : forall {arg : Type}, (Ty arg) -> (option type_annot) -> + Ty ('typed_contract arg)*) +| Operation_t : (option type_annot) -> Ty operation +| Chain_id_t : (option type_annot) -> + Ty Tezos_protocol_environment_alpha.Environment.Chain_id.t + +with stack_ty : forall (ty : Type), Type := +| Item_t : forall {rest ty : Type}, (Ty ty) -> (stack_ty rest) -> + (option var_annot) -> stack_ty (ty * rest) +| Empty_t : stack_ty 'end_of_stack + +with instr : forall (bef aft : Type), Type := +| Drop : forall {A rest : Type}, instr (A * rest) rest +| Dup : forall {rest top : Type}, instr (top * rest) (top * (top * rest)) +| Swap : forall {rest tip top : Type}, + instr (tip * (top * rest)) (top * (tip * rest)) +| Const : forall {rest ty : Type}, ty -> instr rest (ty * rest) +| Cons_pair : forall {car cdr rest : Type}, + instr (car * (cdr * rest)) ((pair car cdr) * rest) +| Car : forall {B car rest : Type}, instr ((pair car B) * rest) (car * rest) +| Cdr : forall {A cdr rest : Type}, instr ((pair A cdr) * rest) (cdr * rest) +| Cons_some : forall {rest v : Type}, instr (v * rest) ((option v) * rest) +| Cons_none : forall {a rest : Type}, (Ty a) -> instr rest ((option a) * rest) +| If_none : forall {a aft bef : Type}, ('descr bef aft) -> + ('descr (a * bef) aft) -> instr ((option a) * bef) aft +| Left : forall {l r rest : Type}, instr (l * rest) ((union l r) * rest) +| Right : forall {l r rest : Type}, instr (r * rest) ((union l r) * rest) +| If_left : forall {aft bef l r : Type}, ('descr (l * bef) aft) -> + ('descr (r * bef) aft) -> instr ((union l r) * bef) aft +| Cons_list : forall {a rest : Type}, + instr (a * ((list a) * rest)) ((list a) * rest) +| Nil : forall {a rest : Type}, instr rest ((list a) * rest) +| If_cons : forall {a aft bef : Type}, ('descr (a * ((list a) * bef)) aft) -> + ('descr bef aft) -> instr ((list a) * bef) aft +| List_map : forall {a b rest : Type}, ('descr (a * rest) (b * rest)) -> + instr ((list a) * rest) ((list b) * rest) +| List_iter : forall {a rest : Type}, ('descr (a * rest) rest) -> + instr ((list a) * rest) rest +| List_size : forall {a rest : Type}, + instr ((list a) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Empty_set : forall {a rest : Type}, (comparable_ty a) -> + instr rest ((set a) * rest) +| Set_iter : forall {a rest : Type}, ('descr (a * rest) rest) -> + instr ((set a) * rest) rest +| Set_mem : forall {elt rest : Type}, + instr (elt * ((set elt) * rest)) (bool * rest) +| Set_update : forall {elt rest : Type}, + instr (elt * (bool * ((set elt) * rest))) ((set elt) * rest) +| Set_size : forall {a rest : Type}, + instr ((set a) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Empty_map : forall {a rest v : Type}, (comparable_ty a) -> (Ty v) -> + instr rest ((map a v) * rest) +| Map_map : forall {a r rest v : Type}, ('descr ((a * v) * rest) (r * rest)) -> + instr ((map a v) * rest) ((map a r) * rest) +| Map_iter : forall {a rest v : Type}, ('descr ((a * v) * rest) rest) -> + instr ((map a v) * rest) rest +| Map_mem : forall {a rest v : Type}, + instr (a * ((map a v) * rest)) (bool * rest) +| Map_get : forall {a rest v : Type}, + instr (a * ((map a v) * rest)) ((option v) * rest) +| Map_update : forall {a rest v : Type}, + instr (a * ((option v) * ((map a v) * rest))) ((map a v) * rest) +| Map_size : forall {a b rest : Type}, + instr ((map a b) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +(*| Empty_big_map : forall {a rest v : Type}, (comparable_ty a) -> (Ty v) -> + instr rest (('big_map a v) * rest) +| Big_map_mem : forall {a rest v : Type}, + instr (a * (('big_map a v) * rest)) (bool * rest) +| Big_map_get : forall {a rest v : Type}, + instr (a * (('big_map a v) * rest)) ((option v) * rest) +| Big_map_update : forall {key rest value : Type}, + instr (key * ((option value) * (('big_map key value) * rest))) + (('big_map key value) * rest)*) +| Concat_string : forall {rest : Type}, + instr ((list string) * rest) (string * rest) +| Concat_string_pair : forall {rest : Type}, + instr (string * (string * rest)) (string * rest) +| Slice_string : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * (string * rest))) + ((option string) * rest) +| String_size : forall {rest : Type}, + instr (string * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Concat_bytes : forall {rest : Type}, + instr ((list Tezos_protocol_environment_alpha.Environment.MBytes.t) * rest) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Concat_bytes_pair : forall {rest : Type}, + instr + (Tezos_protocol_environment_alpha.Environment.MBytes.t * + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest)) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Slice_bytes : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest))) + ((option Tezos_protocol_environment_alpha.Environment.MBytes.t) * rest) +| Bytes_size : forall {rest : Type}, + instr (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Add_seconds_to_timestamp : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest) +| Add_timestamp_to_seconds : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest) +| Sub_timestamp_seconds : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest) +| Diff_timestamps : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * + (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Add_tez : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Sub_tez : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Mul_teznat : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Mul_nattez : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)) + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Ediv_teznat : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((option + (pair Tezos_raw_protocol_alpha.Alpha_context.Tez.t + Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest) +| Ediv_tez : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)) + ((option + (pair + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) + Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest) +| Or : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest) +| And : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest) +| Xor : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest) +| Not : forall {rest : Type}, instr (bool * rest) (bool * rest) +| Is_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) + ((option + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)) * rest) +| Neg_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Neg_int : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Abs_int : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Int_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Add_intint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Add_intnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Add_natint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Add_natnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Sub_int : forall {rest s t : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num s) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num t) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Mul_intint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Mul_intnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Mul_natint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Mul_natnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Ediv_intint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((option + (pair + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest) +| Ediv_intnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((option + (pair + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest) +| Ediv_natint : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)) + ((option + (pair + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest) +| Ediv_natnat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((option + (pair + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) + (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest) +| Lsl_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Lsr_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Or_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| And_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| And_int_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Xor_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Not_nat : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Not_int : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Seq : forall {aft bef trans : Type}, ('descr bef trans) -> ('descr trans aft) + -> instr bef aft +| If : forall {aft bef : Type}, ('descr bef aft) -> ('descr bef aft) -> + instr (bool * bef) aft +| Loop : forall {rest : Type}, ('descr rest (bool * rest)) -> + instr (bool * rest) rest +| Loop_left : forall {a b rest : Type}, ('descr (a * rest) ((union a b) * rest)) + -> instr ((union a b) * rest) (b * rest) +| Dip : forall {aft bef top : Type}, ('descr bef aft) -> + instr (top * bef) (top * aft) +| Exec : forall {arg rest ret : Type}, + instr (arg * ((lambda arg ret) * rest)) (ret * rest) +| Apply : forall {arg remaining rest ret : Type}, (Ty arg) -> + instr (arg * ((lambda (arg * remaining) ret) * rest)) + ((lambda remaining ret) * rest) +| Lambda : forall {arg rest ret : Type}, (lambda arg ret) -> + instr rest ((lambda arg ret) * rest) +| Failwith : forall {a aft rest : Type}, (Ty a) -> instr (a * rest) aft +| Nop : forall {rest : Type}, instr rest rest +| Compare : forall {a rest : Type}, (comparable_ty a) -> + instr (a * (a * rest)) + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) +| Eq : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +| Neq : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +| Lt : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +| Gt : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +| Le : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +| Ge : forall {rest : Type}, + instr + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest) +(*| Address : forall {A rest : Type}, + instr (('typed_contract A) * rest) (address * rest)*) +(*| Contract : forall {p rest : Type}, (Ty p) -> string -> + instr (address * rest) ((option ('typed_contract p)) * rest)*) +(*| Transfer_tokens : forall {arg rest : Type}, + instr + (arg * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * + (('typed_contract arg) * rest))) (operation * rest)*) +| Create_account : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * + ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * + (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)))) + (operation * (address * rest)) +(*| Implicit_account : forall {rest : Type}, + instr (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest) + (('typed_contract unit) * rest)*) +| Create_contract : forall {g p rest : Type}, (Ty g) -> (Ty p) -> + (lambda (p * g) ((list operation) * g)) -> (option string) -> + instr + (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * + ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * + (bool * + (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest)))))) + (operation * (address * rest)) +| Create_contract_2 : forall {g p rest : Type}, (Ty g) -> (Ty p) -> + (lambda (p * g) ((list operation) * g)) -> (option string) -> + instr + ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * + (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest))) + (operation * (address * rest)) +| Set_delegate : forall {rest : Type}, + instr ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * rest) + (operation * rest) +| Now : forall {rest : Type}, + instr rest (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest) +| Balance : forall {rest : Type}, + instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Check_signature : forall {rest : Type}, + instr + (Tezos_raw_protocol_alpha.Alpha_context.public_key * + (Tezos_raw_protocol_alpha.Alpha_context.signature * + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest))) + (bool * rest) +| Hash_key : forall {rest : Type}, + instr (Tezos_raw_protocol_alpha.Alpha_context.public_key * rest) + (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest) +| Pack : forall {a rest : Type}, (Ty a) -> + instr (a * rest) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Unpack : forall {a rest : Type}, (Ty a) -> + instr (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) + ((option a) * rest) +| Blake2b : forall {rest : Type}, + instr (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Sha256 : forall {rest : Type}, + instr (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Sha512 : forall {rest : Type}, + instr (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) + (Tezos_protocol_environment_alpha.Environment.MBytes.t * rest) +| Steps_to_quota : forall {rest : Type}, + instr rest + ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest) +| Source : forall {rest : Type}, instr rest (address * rest) +| Sender : forall {rest : Type}, instr rest (address * rest) +(*| Self : forall {p rest : Type}, (Ty p) -> string -> + instr rest (('typed_contract p) * rest)*) +| Amount : forall {rest : Type}, + instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest) +| Dig : forall {aft bef rest x : Type}, Z -> + (stack_prefix_preservation_witness (x * rest) rest bef aft) -> + instr bef (x * aft) +| Dug : forall {aft bef rest x : Type}, Z -> + (stack_prefix_preservation_witness rest (x * rest) bef aft) -> + instr (x * bef) aft +| Dipn : forall {aft bef faft fbef : Type}, Z -> + (stack_prefix_preservation_witness fbef faft bef aft) -> ('descr fbef faft) -> + instr bef aft +| Dropn : forall {C bef rest : Type}, Z -> + (stack_prefix_preservation_witness rest rest bef C) -> instr bef rest +| ChainId : forall {rest : Type}, + instr rest + (Tezos_protocol_environment_alpha.Environment.Chain_id.t * rest) + +with stack_prefix_preservation_witness : forall + (bef aft bef_suffix aft_suffix : Type), Type := +| Prefix : forall {aft bef faft fbef x : Type}, + (stack_prefix_preservation_witness fbef faft bef aft) -> + stack_prefix_preservation_witness fbef faft (x * bef) (x * aft) +| Rest : forall {aft bef : Type}, + stack_prefix_preservation_witness bef aft bef aft + +where "'script" := (fun (arg storage : Type) => + script_skeleton (lambda (pair arg storage) (pair (list operation) storage)) + (Ty arg) storage (Ty storage) (option string)) +and "'end_of_stack" := (unit) +and "'typed_contract" := (fun (arg : Type) => (Ty arg) * address) +and "'big_map" := (fun (key value : Type) => + big_map_skeleton (option Tezos_protocol_environment_alpha.Environment.Z.t) + (map key (option value)) (Ty key) (Ty value)) +and "'descr" := (fun (bef aft : Type) => + descr_skeleton Tezos_raw_protocol_alpha.Alpha_context.Script.location + (stack_ty bef) (stack_ty aft) (instr bef aft)). + +Definition script := 'script. +Definition end_of_stack := 'end_of_stack. +Definition typed_contract := 'typed_contract. +Definition big_map := 'big_map. +Definition descr := 'descr. + +Inductive ex_big_map : Type := +| Ex_bm : forall {key value : Type}, (big_map key value) -> ex_big_map. diff --git a/src/michocoq/of_ocaml/syntax_type_equiv.v b/src/michocoq/of_ocaml/syntax_type_equiv.v new file mode 100644 index 0000000000000000000000000000000000000000..a69cc57f5a757b8ce06ad96a7ab6d34c71ad1eba --- /dev/null +++ b/src/michocoq/of_ocaml/syntax_type_equiv.v @@ -0,0 +1,486 @@ +(** Comparison of the OCaml and MiChoCoq types. *) +Require Import Coq.Lists.List. +Require of_ocaml.script_typed_ir_ml syntax_type. + +Import ListNotations. + +(** Utilities and notations to manipulate the option type. *) +Module Option. + Definition bind {A B : Type} + (x : Datatypes.option A) (f : A -> Datatypes.option B) + : Datatypes.option B := + match x with + | Some x => f x + | None => None + end. + + (** Notation for the bind with a typed answer. *) + Notation "'let?' x : A ':=' X 'in' Y" := + (bind X (fun (x : A) => Y)) + (at level 200, x pattern, X at level 100, A at level 200, Y at level 200). + + (** Notation for the bind. *) + Notation "'let?' x ':=' X 'in' Y" := + (bind X (fun x => Y)) + (at level 200, x pattern, X at level 100, Y at level 200). + + Definition true_or_None (A : Datatypes.option Prop) : Prop := + match A with + | Some A => A + | None => True + end. + + Lemma true_or_None_case_eq + {T : Type} {e1 : Datatypes.option T} {e2 : T -> Prop} + (A : true_or_None (let? x := e1 in Some (e2 x))) + {x : T} + (H : e1 = Some x) + : e2 x. + rewrite H in A; simpl in A. + exact A. + Qed. +End Option. + +Import Option. + +(** Bijection between OCaml and MiChoCoq comparable types. This bijection is + not a true bijection for the following reasons: + * some cases from OCaml are not imported by coq-of-ocaml; + * most of the annotations are missing in MiChoCoq; + * we define the equality on OCaml terms with an inductive, as this equality + is heterogeneous and we did not achieve to use the heterogeneous equality + of the Coq standard library with success. +*) +Module comparable. + Import script_typed_ir_ml syntax_type. + + Definition ocaml_leaf_to_coq {A Kind : Type} + (comparable : script_typed_ir_ml.comparable_struct A Kind) + : Datatypes.option syntax_type.simple_comparable_type := + match comparable with + | Int_key _ => Some int + | Nat_key _ => Some nat + | String_key _ => Some string + | Bytes_key _ => Some bytes + | Mutez_key _ => Some mutez + | Bool_key _ => Some bool + | Key_hash_key _ => Some key_hash + | Timestamp_key _ => Some timestamp + | Address_key _ => Some address + (* This case should not be used with GADTs *) + | Pair_key _ _ _ => None + end. + + Fixpoint ocaml_to_coq {A Kind : Type} + (comparable : script_typed_ir_ml.comparable_struct A Kind) + : Datatypes.option syntax_type.comparable_type := + match comparable with + | Pair_key (comparable_a, _) (comparable_b, _) _ => + let? comparable_a' := ocaml_leaf_to_coq comparable_a in + let? comparable_b' := ocaml_to_coq comparable_b in + Some (Cpair comparable_a' comparable_b') + | _ => + let? comparable' := ocaml_leaf_to_coq comparable in + Some (Comparable_type_simple comparable') + end. + + Definition coq_simple_to_ocaml_typ + (comparable : syntax_type.simple_comparable_type) + : Type := + match comparable with + | string => String.string + | nat => + Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.n + | int => + Tezos_raw_protocol_alpha.Alpha_context.Script_int.num + Tezos_raw_protocol_alpha.Alpha_context.Script_int.z + | bytes => + Tezos_protocol_environment_alpha.Environment.MBytes.t + | bool => Datatypes.bool + | mutez => Tezos_raw_protocol_alpha.Alpha_context.Tez.t + | address => script_typed_ir_ml.address + | key_hash => Tezos_raw_protocol_alpha.Alpha_context.public_key_hash + | timestamp => Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t + end. + + Definition coq_simple_to_ocaml + (Kind : Type) + (comparable : syntax_type.simple_comparable_type) + : script_typed_ir_ml.comparable_struct + (coq_simple_to_ocaml_typ comparable) + Kind + := + match comparable with + | string => String_key None + | nat => Nat_key None + | int => Int_key None + | bytes => Bytes_key None + | bool => Bool_key None + | mutez => Mutez_key None + | address => Address_key None + | key_hash => Key_hash_key None + | timestamp => Timestamp_key None + end. + + Fixpoint coq_to_ocaml_typ + (comparable : syntax_type.comparable_type) + : Type := + match comparable with + | Comparable_type_simple comparable => coq_simple_to_ocaml_typ comparable + | Cpair comparable_a comparable_b => + coq_simple_to_ocaml_typ comparable_a * coq_to_ocaml_typ comparable_b + end. + + Fixpoint coq_to_ocaml (comparable : syntax_type.comparable_type) + : script_typed_ir_ml.comparable_ty (coq_to_ocaml_typ comparable) := + match comparable with + | Comparable_type_simple comparable => + coq_simple_to_ocaml comb comparable + | Cpair comparable_a comparable_b => + Pair_key + (coq_simple_to_ocaml leaf comparable_a, None) + (coq_to_ocaml comparable_b, None) + None + end. + + Fixpoint coq_simple_to_ocaml_to_coq_eq {Kind : Type} + (comparable : syntax_type.simple_comparable_type) + : ocaml_leaf_to_coq (coq_simple_to_ocaml Kind comparable) = Some comparable. + destruct comparable; reflexivity. + Qed. + + Fixpoint coq_to_ocaml_to_coq_eq (comparable : syntax_type.comparable_type) + : ocaml_to_coq (coq_to_ocaml comparable) = Some comparable. + destruct comparable as [simple | simple comparable]; simpl. + - destruct simple; reflexivity. + - rewrite coq_simple_to_ocaml_to_coq_eq. + rewrite coq_to_ocaml_to_coq_eq. + reflexivity. + Qed. + + Definition ocaml_leaf_to_coq_to_ocaml_typ_eq {A : Type} + (comparable : comparable_struct A leaf) + : true_or_None ( + let? comparable' := ocaml_leaf_to_coq comparable in + Some (coq_simple_to_ocaml_typ comparable' = A) + ). + destruct comparable; simpl; reflexivity. + Qed. + + Fixpoint ocaml_to_coq_to_ocaml_typ_eq {A Kind : Type} + (comparable : script_typed_ir_ml.comparable_struct A Kind) + : true_or_None ( + let? comparable' := ocaml_to_coq comparable in + Some (coq_to_ocaml_typ comparable' = A) + ). + destruct comparable; simpl; try reflexivity. + destruct p; destruct p0; simpl. + case_eq (ocaml_leaf_to_coq c); simpl; trivial. + intros s Hs. + case_eq (ocaml_to_coq c0); simpl; trivial. + intros c1 Hc1. + rewrite (true_or_None_case_eq (ocaml_leaf_to_coq_to_ocaml_typ_eq c) Hs). + rewrite (true_or_None_case_eq (ocaml_to_coq_to_ocaml_typ_eq _ _ c0) Hc1). + reflexivity. + Qed. + + Module eq. + Import script_typed_ir_ml. + + Inductive t : + forall {A B : Type} (Kind_A Kind_B : Type), + script_typed_ir_ml.comparable_struct A Kind_A -> + script_typed_ir_ml.comparable_struct B Kind_B -> + Prop := + | Int : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Int_key annot_a) (Int_key annot_b) + | Nat : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Nat_key annot_a) (Nat_key annot_b) + | String_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (String_key annot_a) (String_key annot_b) + | Bytes_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Bytes_key annot_a) (Bytes_key annot_b) + | Mutez_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Mutez_key annot_a) (Mutez_key annot_b) + | Bool_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Bool_key annot_a) (Bool_key annot_b) + | Key_hash_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Key_hash_key annot_a) (Key_hash_key annot_b) + | Timestamp_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Timestamp_key annot_a) (Timestamp_key annot_b) + | Address_key : + forall Kind_A Kind_B annot_a annot_b, + t Kind_A Kind_B (Address_key annot_a) (Address_key annot_b) + | Pair : + forall {A_A A_B B_A B_B : Type}, + forall Kind_A Kind_B, + forall annot_a_a annot_a_b annot_a annot_b_a annot_b_b annot_b, + forall + (comparable_a_a : script_typed_ir_ml.comparable_struct A_A leaf) + (comparable_a_b : script_typed_ir_ml.comparable_struct A_B Kind_A) + (comparable_b_a : script_typed_ir_ml.comparable_struct B_A leaf) + (comparable_b_b : script_typed_ir_ml.comparable_struct B_B Kind_B), + t leaf leaf comparable_a_a comparable_b_a -> + t Kind_A Kind_B comparable_a_b comparable_b_b -> + t + comb comb + (Pair_key (comparable_a_a, annot_a_a) (comparable_a_b, annot_a_b) annot_a) + (Pair_key (comparable_b_a, annot_b_a) (comparable_b_b, annot_b_b) annot_b). + Arguments t {_ _ _ _} _ _. + End eq. + + Definition ocaml_leaf_to_coq_to_ocaml_eq {A Kind : Type} + (comparable : script_typed_ir_ml.comparable_struct A Kind) + : true_or_None ( + let? comparable' := ocaml_leaf_to_coq comparable in + Some (eq.t (coq_simple_to_ocaml Kind comparable') comparable) + ). + destruct comparable; simpl; constructor. + Qed. + + Fixpoint ocaml_to_coq_to_ocaml_eq {A Kind : Type} + (comparable : script_typed_ir_ml.comparable_struct A Kind) + : true_or_None ( + let? comparable' := ocaml_to_coq comparable in + Some (eq.t (coq_to_ocaml comparable') comparable) + ). + destruct comparable; simpl; try constructor. + destruct p; destruct p0; simpl. + case_eq (ocaml_leaf_to_coq c); simpl; trivial. + intros s Hs. + case_eq (ocaml_to_coq c0); simpl; trivial. + intros c1 Hc1. + constructor. + - apply (true_or_None_case_eq (ocaml_leaf_to_coq_to_ocaml_eq c) Hs). + - apply (true_or_None_case_eq (ocaml_to_coq_to_ocaml_eq _ _ c0) Hc1). + Qed. +End comparable. + +(** Injection from MiChoCoq types to OCaml types. We should be able to show that + this injection is actually a bijection. This bijection would be partial, for + the same reasons as for the comparable types. +*) +Module typ. + Import script_typed_ir_ml syntax_type. + + Fixpoint ocaml_to_coq {ty : Type} (typ : script_typed_ir_ml.Ty ty) + : Datatypes.option syntax_type.type := + match typ with + | Unit_t _ => Some (unit) + | Int_t _ => Some (Comparable_type int) + | Nat_t _ => Some (Comparable_type nat) + | Signature_t _ => Some (signature) + | String_t _ => Some (Comparable_type string) + | Bytes_t _ => Some (Comparable_type bytes) + | Mutez_t _ => Some (Comparable_type mutez) + | Key_hash_t _ => Some (Comparable_type key_hash) + | Key_t _ => Some (key) + | Timestamp_t _ => Some (Comparable_type timestamp) + | Address_t _ => Some (Comparable_type address) + | Bool_t _ => Some (Comparable_type bool) + | Pair_t (typ_a, _, _) (typ_b, _, _) _ _ => + let? typ_a' := ocaml_to_coq typ_a in + let? typ_b' := ocaml_to_coq typ_b in + Some (pair typ_a' typ_b') + | Union_t (typ_a, _) (typ_b, _) _ _ => (* Annotations ignored unfortunately *) + let? typ_a' := ocaml_to_coq typ_a in + let? typ_b' := ocaml_to_coq typ_b in + Some (or typ_a' None typ_b' None) + | Lambda_t typ_arg typ_ret _ => + let? typ_arg' := ocaml_to_coq typ_arg in + let? typ_ret' := ocaml_to_coq typ_ret in + Some (lambda typ_arg' typ_ret') + | Option_t typ _ _ => + let? typ' := ocaml_to_coq typ in + Some (option typ') + | List_t typ _ _ => + let? typ' := ocaml_to_coq typ in + Some (list typ') + | Set_t typ_key _ => + let? typ_key' := comparable.ocaml_to_coq typ_key in + Some (set typ_key') + | Map_t typ_key typ _ _ => + let? typ_key' := comparable.ocaml_to_coq typ_key in + let? typ' := ocaml_to_coq typ in + Some (map typ_key' typ') + | Operation_t _ => Some operation + | Chain_id_t _ => Some chain_id + end. + + Fixpoint coq_to_ocaml_typ (typ : syntax_type.type) : Type := + match typ with + | Comparable_type comparable_typ => + comparable.coq_simple_to_ocaml_typ comparable_typ + | key => Tezos_raw_protocol_alpha.Alpha_context.public_key + | unit => Datatypes.unit + | signature => Tezos_raw_protocol_alpha.Alpha_context.signature + | option typ => Datatypes.option (coq_to_ocaml_typ typ) + | list typ => Datatypes.list (coq_to_ocaml_typ typ) + | set comparable_typ => + script_typed_ir_ml.set (comparable.coq_to_ocaml_typ comparable_typ) + | contract typ => typed_contract (coq_to_ocaml_typ typ) + | operation => script_typed_ir_ml.operation + | pair typ_a typ_b => coq_to_ocaml_typ typ_a * coq_to_ocaml_typ typ_b + | or typ_a _ typ_b _ => union (coq_to_ocaml_typ typ_a) (coq_to_ocaml_typ typ_b) + | lambda typ_arg typ_res => + script_typed_ir_ml.lambda + (coq_to_ocaml_typ typ_arg) + (coq_to_ocaml_typ typ_res) + | map comparable_typ typ => + script_typed_ir_ml.map + (comparable.coq_to_ocaml_typ comparable_typ) + (coq_to_ocaml_typ typ) + | big_map comparable_typ typ => + script_typed_ir_ml.big_map + (comparable.coq_to_ocaml_typ comparable_typ) + (coq_to_ocaml_typ typ) + | chain_id => Tezos_protocol_environment_alpha.Environment.Chain_id.t + end. + + Fixpoint coq_comparable_to_ocaml_typ_eq + (comparable : syntax_type.comparable_type) + : comparable.coq_to_ocaml_typ comparable = + coq_to_ocaml_typ (syntax_type.comparable_type_to_type comparable). + destruct comparable; simpl. + - reflexivity. + - rewrite coq_comparable_to_ocaml_typ_eq. + reflexivity. + Qed. + + Fixpoint coq_to_ocaml (typ : syntax_type.type) + : Datatypes.option (script_typed_ir_ml.Ty (coq_to_ocaml_typ typ)) := + match typ with + | Comparable_type comparable_typ => + Some ( + match comparable_typ return + script_typed_ir_ml.Ty (comparable.coq_simple_to_ocaml_typ comparable_typ) + with + | string => String_t None + | nat => Nat_t None + | int => Int_t None + | bytes => Bytes_t None + | bool => Bool_t None + | mutez => Mutez_t None + | address => Address_t None + | key_hash => Key_hash_t None + | timestamp => Timestamp_t None + end + ) + | key => Some (Key_t None) + | unit => Some (Unit_t None) + | signature => Some (Signature_t None) + | option typ => + let? typ' := coq_to_ocaml typ in + Some (Option_t typ' None false) + | list typ => + let? typ' := coq_to_ocaml typ in + Some (List_t typ' None false) + | set typ_key => + let typ_key' := comparable.coq_to_ocaml typ_key in + Some (Set_t typ_key' None) + | operation => Some (Operation_t None) + | pair typ_a typ_b => + let? typ_a' := coq_to_ocaml typ_a in + let? typ_b' := coq_to_ocaml typ_b in + Some (Pair_t + (typ_a', None, None) + (typ_b', None, None) + None + false + ) + | or typ_a None typ_b None => + let? typ_a' := coq_to_ocaml typ_a in + let? typ_b' := coq_to_ocaml typ_b in + Some (Union_t + (typ_a', None) + (typ_b', None) + None + false + ) + | or _ _ _ _ => None + | lambda typ_arg typ_ret => + let? typ_arg' := coq_to_ocaml typ_arg in + let? typ_ret' := coq_to_ocaml typ_ret in + Some (Lambda_t typ_arg' typ_ret' None) + | map typ_key typ => + let typ_key' := comparable.coq_to_ocaml typ_key in + let? typ' := coq_to_ocaml typ in + Some (Map_t typ_key' typ' None false) + | chain_id => Some (Chain_id_t None) + | _ => None + end. + + Ltac case_eq_rewrite_in_H e e' He H:= + case_eq e; simpl; trivial; + intros e' He; + rewrite He in H; simpl in H; + clear He. + + Fixpoint coq_to_ocaml_to_coq_eq (typ : syntax_type.type) + : true_or_None ( + let? typ' := coq_to_ocaml typ in + let? typ'' := ocaml_to_coq typ' in + Some (typ'' = typ) + ). + destruct typ; simpl; + try reflexivity; + (* one recursive case *) + try ( + assert (H_ind := coq_to_ocaml_to_coq_eq typ); + case_eq_rewrite_in_H (coq_to_ocaml typ) typ' Htyp H_ind; + case_eq_rewrite_in_H (ocaml_to_coq typ') typ'' Htyp' H_ind; + congruence + ); + (* two recursive cases *) + try ( + assert (H_ind_typ1 := coq_to_ocaml_to_coq_eq typ1); + assert (H_ind_typ2 := coq_to_ocaml_to_coq_eq typ2); + case_eq_rewrite_in_H (coq_to_ocaml typ1) typ1' Htyp1 H_ind_typ1; + case_eq_rewrite_in_H (coq_to_ocaml typ2) typ2' Htyp2 H_ind_typ2; + case_eq_rewrite_in_H (ocaml_to_coq typ1') typ1'' Htyp1' H_ind_typ1; + case_eq_rewrite_in_H (ocaml_to_coq typ2') typ2'' Htyp2' H_ind_typ2; + congruence + ). + - destruct s; simpl; reflexivity. + - rewrite comparable.coq_to_ocaml_to_coq_eq; simpl. + reflexivity. + - destruct a; destruct a0; try reflexivity. + assert (H_ind_typ1 := coq_to_ocaml_to_coq_eq typ1); + assert (H_ind_typ2 := coq_to_ocaml_to_coq_eq typ2); + case_eq_rewrite_in_H (coq_to_ocaml typ1) typ1' Htyp1 H_ind_typ1; + case_eq_rewrite_in_H (coq_to_ocaml typ2) typ2' Htyp2 H_ind_typ2; + case_eq_rewrite_in_H (ocaml_to_coq typ1') typ1'' Htyp1' H_ind_typ1; + case_eq_rewrite_in_H (ocaml_to_coq typ2') typ2'' Htyp2' H_ind_typ2; + congruence. + - assert (H_ind_typ := coq_to_ocaml_to_coq_eq typ). + case_eq_rewrite_in_H (coq_to_ocaml typ) typ' Htyp H_ind_typ. + rewrite comparable.coq_to_ocaml_to_coq_eq; simpl. + case_eq_rewrite_in_H (ocaml_to_coq typ') typ'' Htyp' H_ind_typ. + congruence. + Qed. + + Fixpoint coq_to_ocaml_typs (typs : Datatypes.list syntax_type.type) : Type := + match typs with + | [] => Datatypes.unit + | typ :: typs => coq_to_ocaml_typ typ * coq_to_ocaml_typs typs + end. + + Fixpoint coq_to_ocamls (typs : Datatypes.list syntax_type.type) + : Datatypes.option (script_typed_ir_ml.stack_ty (coq_to_ocaml_typs typs)) := + match typs with + | [] => Some Empty_t + | typ :: typs => + let? typ' := coq_to_ocaml typ in + let? typs' := coq_to_ocamls typs in + Some (Item_t typ' typs' None) + end. +End typ. diff --git a/src/michocoq/optimizer.v b/src/michocoq/optimizer.v new file mode 100644 index 0000000000000000000000000000000000000000..da29413164d4b28b63b0922fd5bb238f2fcdf70c --- /dev/null +++ b/src/michocoq/optimizer.v @@ -0,0 +1,108 @@ +(* Open Source License *) +(* Copyright (c) 2019 Nomadic Labs. *) + +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"), *) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) + +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) + +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) + +(** Michelson optimizer working on the untyped syntax *) + +Require Import Michocoq.untyped_syntax. +Require Import ZArith. + +(* Optimizations *) + +Fixpoint visit_instruction + (F : instruction_seq -> instruction_seq) + (i : instruction) {struct i} : instruction := + match i with + | DIP n i => DIP n (visit_instruction_seq F i) + | IF_ f i1 i2 => + IF_ f (visit_instruction_seq F i1) (visit_instruction_seq F i2) + | LOOP_ f i => + LOOP_ f (visit_instruction_seq F i) + | ITER i => ITER (visit_instruction_seq F i) + | MAP i => MAP (visit_instruction_seq F i) + | LAMBDA a b i => LAMBDA a b i + | CREATE_CONTRACT a b an i => CREATE_CONTRACT a b an i + | PUSH ty x => PUSH ty x + | FAILWITH => FAILWITH + | SELF an => SELF an + | EXEC => EXEC + | instruction_opcode op => op + | Instruction_seq i => + Instruction_seq (visit_instruction_seq F i) + end +with +visit_instruction_seq f i {struct i} := + match i with + | NOOP => f NOOP + | SEQ i1 i2 => + let i1' := visit_instruction f i1 in + let i2' := visit_instruction_seq f i2 in + f (SEQ i1' i2') + end. + +Definition dig0dug0 := + visit_instruction_seq + (fun i => + match i with + | SEQ (DIG 0) i => i + | SEQ (DUG 0) i => i + | SEQ (DROP 0) i => i + | SEQ (DIP 0 i1) i2 => instruction_app i1 i2 + | SEQ (DIG 1) i => SEQ SWAP i + | SEQ (DUG 1) i => SEQ SWAP i + | SEQ (Instruction_seq i1) i2 => instruction_app i1 i2 + | i => i + end). + +Definition digndugn := + visit_instruction_seq + (fun i => + match i with + | SEQ (DIG n1) (SEQ (DUG n2) i') => + if (n1 =? n2) then i' else i + | i => i + end). + +Definition swapswap := + visit_instruction_seq + (fun i => + match i with + | SEQ SWAP (SEQ SWAP i) => i + | i => i + end). + +Definition push_drop := + visit_instruction_seq + (fun i => + match i with + | SEQ (PUSH _ _) (SEQ (DROP 1) i) => i + | SEQ (PUSH _ _) (SEQ (DROP (S n)) i) => SEQ (DROP n) i + | i => i + end). + +(** Clean some stuff in the code *) +Definition cleanup (ins : instruction_seq) : instruction_seq := + push_drop + (swapswap + (digndugn + (dig0dug0 ins))). + +(** Optimize the code (currently only cleanup of useless instructions *) +Definition optimize := cleanup. diff --git a/src/michocoq/semantics.v b/src/michocoq/semantics.v index 4aa6db7e6c0b311336820db4d7ef7858d3f70f9a..4cef955bdba6cfe57c1408934543efab323fe3c9 100644 --- a/src/michocoq/semantics.v +++ b/src/michocoq/semantics.v @@ -22,95 +22,316 @@ (* Operational semantics of the Michelson language *) -Require Import ZArith. +Require Import ZArith Lia. Require Import String. Require Import syntax macros. -Require NPeano. +Require untyped_syntax untyper. +Require NPeano Eqdep_dec. Require Import comparable error. Import error.Notations. -Module Type SelfType. - Parameter self_type : type. -End SelfType. +Module Type ContractContext. + Parameter get_contract_type : + smart_contract_address_constant -> Datatypes.option type. +End ContractContext. -Module EnvDef(C : ContractContext). +Definition ediv_Z x y := + (if y =? 0 then None else + let d := x / y in + let r := x mod y in + if y >? 0 then Some (d, Z.to_N r) + else if r =? 0 then Some (d, 0%N) + else Some (d + 1, Z.to_N (r - y)))%Z. + +Lemma ediv_Z_correct_pos x y (Hy : (y > 0)%Z) d r : + (Some (x / y, Z.to_N (x mod y)) = Some (d, r) <-> (y * d + Z.of_N r = x /\ 0 <= Z.of_N r < Z.abs y))%Z. +Proof. + rewrite Z.abs_eq; [|lia]. + split. + - intro H; injection H; clear H. + intros; subst. + assert (0 <= x mod y < y)%Z as Hbound by (apply Z.mod_pos_bound; lia). + rewrite Z2N.id; [|apply Hbound]. + split; [|assumption]. + symmetry. + apply Z_div_mod_eq. + assumption. + - intros (He, Hbound). + f_equal. + assert (d = x / y)%Z. + + subst x. + rewrite Z.mul_comm. + rewrite Z_div_plus_full_l; [|lia]. + assert (Z.of_N r / y = 0)%Z as Hr by (apply Z.div_small_iff; lia). + lia. + + subst d. + f_equal. + rewrite Zmod_eq; [|lia]. + assert (x - x / y * y = Z.of_N r)%Z as Hr by lia. + rewrite Hr. + apply N2Z.id. +Qed. + +Lemma ediv_Z_correct x y d r : + ediv_Z x y = Some (d, r) <-> (y * d + Z.of_N r = x /\ 0 <= Z.of_N r < Z.abs y)%Z. +Proof. + unfold ediv_Z. + case_eq (y =? 0)%Z. + - intro Hy. + apply Z.eqb_eq in Hy. + subst y. + simpl. + split. + + discriminate. + + intros (_, Habs). + exfalso. + lia. + - intro Hy. + apply Z.eqb_neq in Hy. + case_eq (y >? 0)%Z. + + intro Hy2. + apply Z.gtb_lt in Hy2. + apply ediv_Z_correct_pos; lia. + + intro Hy2. + rewrite Z.gtb_ltb in Hy2. + rewrite Z.ltb_ge in Hy2. + assert (- y > 0)%Z as Hym by lia. + specialize (ediv_Z_correct_pos x (- y) Hym (- d) r); intro Hm. + rewrite Z.abs_opp in Hm. + case_eq (x mod y =? 0)%Z. + * intro Hr. + apply Z.eqb_eq in Hr. + assert (x mod - y = 0)%Z as Hmodm by (apply Z_mod_zero_opp_r; assumption). + rewrite Hmodm in Hm. + rewrite Z2N.inj_0 in Hm. + rewrite Z.mul_opp_opp in Hm. + rewrite <- Hm. + apply Z_div_zero_opp_r in Hr. + rewrite Hr. + split. + -- intuition congruence. + -- intro H; injection H; clear H. + intros. + f_equal. + f_equal; lia. + * intro Hr. + apply Z.eqb_neq in Hr. + assert (x mod - y = x mod y - y)%Z as Hmodm by (apply Z_mod_nz_opp_r; congruence). + rewrite Hmodm in Hm. + rewrite Z.mul_opp_opp in Hm. + rewrite <- Hm. + apply Z_div_nz_opp_r in Hr. + rewrite Hr. + split. + -- intro H; injection H; clear H. + intros. + f_equal. + f_equal; lia. + -- intro H; injection H; clear H. + intros. + f_equal. + f_equal; lia. +Qed. + +Definition ediv_N x y := + if (y =? 0)%N then None else Some (x / y, x mod y)%N. + +Lemma ediv_N_correct x y (Hy : (y <> 0)%N) d r : + (Some (x / y, x mod y) = Some (d, r) <-> (y * d + r = x /\ r < y))%N. +Proof. + split. + - intro H; injection H; clear H. + intros; subst. + assert (x mod y < y)%N as Hbound by (apply N.mod_upper_bound; lia). + split; [|assumption]. + symmetry. + apply N.div_mod. + assumption. + - intros (He, Hbound). + f_equal. + symmetry in He. + f_equal. + + symmetry. + apply N.div_unique with (r := r); assumption. + + symmetry. + apply N.mod_unique with (q := d); assumption. +Qed. + +Lemma instruction_seq_dec self_info tff A B : decidable_types.decidable (instruction_seq self_info tff A B). +Proof. + intros i1 i2. + case (untyped_syntax.instruction_seq_dec + (untyper.untype_instruction_seq untyper.untype_Optimized i1) + (untyper.untype_instruction_seq untyper.untype_Optimized i2)). + - left. + destruct tff. + + assert + (typer.type_instruction_seq + (self_type := self_info) + typer.Optimized + (untyper.untype_instruction_seq untyper.untype_Optimized i1) A = + typer.type_instruction_seq + typer.Optimized + (untyper.untype_instruction_seq untyper.untype_Optimized i2) A) + as H by congruence. + rewrite untyper.untype_type_instruction_seq in H. + rewrite untyper.untype_type_instruction_seq in H. + injection H. + intro H2. + apply (f_equal (fun f => f B)) in H2. + rewrite untyper.tail_fail_change_range_same_seq in H2. + rewrite untyper.tail_fail_change_range_same_seq in H2. + exact H2. + + assert + (typer.type_check_instruction_seq_no_tail_fail + (self_type := self_info) + (typer.type_instruction_seq typer.Optimized) + (untyper.untype_instruction_seq untyper.untype_Optimized i1) A B = + typer.type_check_instruction_seq_no_tail_fail + (typer.type_instruction_seq typer.Optimized) + (untyper.untype_instruction_seq untyper.untype_Optimized i2) A B) as H by congruence. + rewrite untyper.untype_type_check_instruction_seq_no_tail_fail in H; [| apply untyper.untype_type_instruction_seq]. + rewrite untyper.untype_type_check_instruction_seq_no_tail_fail in H; [| apply untyper.untype_type_instruction_seq]. + congruence. + - right. + congruence. +Defined. + +Module Semantics(C : ContractContext). Export C. - Module macros := Macros(C). Export macros. - Fixpoint data (a : type) {struct a} : Set := + + Definition get_address_type + (get_contract_type : + smart_contract_address_constant -> Datatypes.option type) + (sao : comparable_data address * annot_o) + : Datatypes.option type := + let '(addr, ao) := sao in + opt_bind + (match addr with + | Implicit _ => Some unit + | Originated addr => get_contract_type addr + end) + (fun ty => + get_entrypoint_opt ao ty None). + + Fixpoint data g (a : type) {struct a} : Set := match a with | Comparable_type b => comparable_data b | signature => signature_constant | operation => operation_constant | key => key_constant | unit => Datatypes.unit - | pair a b => data a * data b - | or a b => sum (data a) (data b) - | option a => Datatypes.option (data a) - | list a => Datatypes.list (data a) + | pair a b => data g a * data g b + | or a _ b _ => sum (data g a) (data g b) + | option a => Datatypes.option (data g a) + | list a => Datatypes.list (data g a) | set a => set.set (comparable_data a) (compare a) - | map a b => map.map (comparable_data a) (data b) (compare a) - | big_map a b => map.map (comparable_data a) (data b) (compare a) + | map a b => map.map (comparable_data a) (data g b) (compare a) + | big_map a b => map.map (comparable_data a) (data g b) (compare a) | lambda a b => - {tff : Datatypes.bool & - instruction None tff (a ::: nil) (b ::: nil)} - | contract a => {s : contract_constant | get_contract_type s = Some a } + sigT (fun tff : Datatypes.bool => + instruction_seq None tff (a ::: nil) (b ::: nil)) + | contract a => sig (fun sao : (address_constant * annot_o) => get_address_type g sao = Some a ) | chain_id => chain_id_constant end. - Record proto_env {self_ty : Datatypes.option type} : Set := + Lemma address_dec : decidable_types.decidable address_constant. + Proof. + intros x y. + repeat decide equality. + Defined. + + Lemma data_dec {g} {a : type} : decidable_types.decidable (data g a). + Proof. + induction a; simpl. + - intros x y. + apply (@comparable.comparable_data_dec (Comparable_type_simple s)). + - intros x y. repeat decide equality. + - intros x y. repeat decide equality. + - intros x y. repeat decide equality. + - apply decidable_types.option_dec. + assumption. + - apply decidable_types.list_dec. assumption. + - apply set.set_dec. + apply comparable.compare_eq_iff. + - intros (xsao, Hx) (ysao, Hy). + case (decidable_types.pair_dec address_dec (decidable_types.option_dec string_dec) xsao ysao); [|right; congruence]. + intro H; destruct H. + left. + f_equal. + apply Eqdep_dec.UIP_dec. + apply decidable_types.option_dec. + unfold decidable_types.decidable. + apply type_dec. + - intros x y. repeat decide equality. + - apply decidable_types.pair_dec; assumption. + - apply decidable_types.or_dec; assumption. + - apply decidable_types.sigT_dec. + + unfold decidable_types.decidable. + decide equality. + + intro; apply instruction_seq_dec. + - apply map.map_dec. + + apply comparable.compare_eq_iff. + + assumption. + - apply map.map_dec. + + apply comparable.compare_eq_iff. + + assumption. + - intros x y. repeat decide equality. + Defined. + + Record proto_env {self_ty : self_info} {g} : Type := mk_proto_env { - create_contract : forall g p tff, + create_contract : forall st p annot tff, Datatypes.option (comparable_data key_hash) -> tez.mutez -> - syntax.instruction (Some p) tff - (pair p g ::: nil) + syntax.instruction_seq (Some (p, annot)) tff + (pair p st ::: nil) (pair (list operation) g ::: nil) -> - data g -> data (pair operation address); + data g st -> data g (pair operation address); transfer_tokens : forall p, - data p -> tez.mutez -> data (contract p) -> - data operation; + data g p -> tez.mutez -> data g (contract p) -> + data g operation; set_delegate : Datatypes.option (comparable_data key_hash) -> - data operation; + data g operation; balance : tez.mutez; - address_ : forall p, data (contract p) -> data address; - contract_ : forall p, data address -> data (option (contract p)); - source : data address; - sender : data address; - self : match self_ty with - | None => Datatypes.unit - | Some self_ty => data (contract self_ty) - end; + source : data g address; + sender : data g address; + self : + match self_ty with + | None => Datatypes.unit + | Some (ty, self_annot) => + forall annot_opt H, + data g (contract (get_opt (get_entrypoint_opt annot_opt ty self_annot) H)) + end; amount : tez.mutez; - implicit_account : - comparable_data key_hash -> data (contract unit); now : comparable_data timestamp; - hash_key : data key -> comparable_data key_hash; - pack : forall a, data a -> data bytes; - unpack : forall a, data bytes -> data (option a); - blake2b : data bytes -> data bytes; - sha256 : data bytes -> data bytes; - sha512 : data bytes -> data bytes; + hash_key : data g key -> comparable_data key_hash; + pack : forall a, data g a -> data g bytes; + unpack : forall a, data g bytes -> data g (option a); + blake2b : data g bytes -> data g bytes; + sha256 : data g bytes -> data g bytes; + sha512 : data g bytes -> data g bytes; check_signature : - data key -> data signature -> data bytes -> data bool; - chain_id_ : data chain_id + data g key -> data g signature -> data g bytes -> data g bool; + chain_id_ : data g chain_id }. - Definition no_self {self_type} (e : proto_env (self_ty := self_type)) : + Definition no_self + {g self_type} + (e : proto_env (self_ty := self_type)) : proto_env (self_ty := None) := mk_proto_env None + g (create_contract e) (transfer_tokens e) (set_delegate e) (balance e) - (address_ e) - (contract_ e) (source e) (sender e) tt (amount e) - (implicit_account e) (now e) (hash_key e) (pack e) @@ -121,53 +342,54 @@ Module EnvDef(C : ContractContext). (check_signature e) (chain_id_ e). -End EnvDef. - -Module Type Env(ST : SelfType)(C:ContractContext). - Include EnvDef C. - Parameter env : @proto_env (Some ST.self_type). -End Env. - -Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). - - Export E. - - Fixpoint stack (t : stack_type) : Set := + Fixpoint stack g (t : stack_type) : Set := match t with | nil => Datatypes.unit - | cons a A => data a * stack A + | cons a A => data g a * stack g A end. + Lemma stack_dec : forall g A, decidable_types.decidable (stack g A). + Proof. + induction A. + - intros [] []; left; reflexivity. + - intros (x, sx) (y, sy). + case (data_dec x y). + + intro Hxy. + subst x. + case (IHA sx sy); intro; intuition congruence. + + intro; intuition congruence. + Defined. + (** Stack manipulation *) - Inductive stack_ind : stack_type -> Set -> Prop := - | stack_nil : stack_ind nil Datatypes.unit + Inductive stack_ind g : stack_type -> Set -> Prop := + | stack_nil : stack_ind g nil Datatypes.unit | stack_cons : forall a A S, - stack_ind A S -> stack_ind (cons a A) (data a * S). + stack_ind g A S -> stack_ind g (cons a A) (data g a * S). - Lemma stack_iff_stack_ind : forall (t : stack_type) (s : Set), - stack t = s <-> stack_ind t s. + Lemma stack_iff_stack_ind g (t : stack_type) : forall (s : Set), + stack g t = s <-> stack_ind g t s. Proof. - intros t. - induction t; intros s; simpl. + induction t as [|a t]; intros s; simpl. - split; intros; subst. + constructor. + inversion H; reflexivity. - split; intros; subst. - + constructor. rewrite <- (IHt (stack t)); reflexivity. - + inversion H; subst. - assert (stack t = S) by (rewrite (IHt S); assumption); subst; reflexivity. + + constructor. rewrite <- (IHt (stack g t)); reflexivity. + + inversion H; subst. + assert (stack g t = S) by (rewrite (IHt S); assumption); subst; reflexivity. Qed. (* Dig stuff *) - Definition stack_app {l1} {l2} (S1 : stack l1) (S2 : stack l2) : stack (l1+++l2). + Definition stack_app {g l1 l2} (S1 : stack g l1) (S2 : stack g l2) : + stack g (l1+++l2). Proof. - induction l1; simpl. + induction l1 as [|a l1]; simpl. - assumption. - inversion S1. split; auto. Defined. - Definition stack_split {l1 l2} (S : stack (l1 +++ l2)) : (stack l1 * stack l2). + Definition stack_split {g l1 l2} (S : stack g (l1 +++ l2)) : (stack g l1 * stack g l2). Proof. induction l1; simpl. - exact (tt, S). @@ -178,7 +400,8 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). repeat (split; try assumption). Defined. - Definition stack_dig {l1 l2 t} (SA : stack (l1+++t:::l2)) : stack (t:::l1+++l2). + Definition stack_dig {g l1 l2 t} (SA : stack g (l1+++t:::l2)) : + stack g (t:::l1+++l2). Proof. simpl. apply stack_split in SA. @@ -188,7 +411,8 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). apply stack_app; assumption. Defined. - Definition stack_dug {l1 l2 t} (SA : stack (t:::l1+++l2)) : stack (l1+++t:::l2). + Definition stack_dug {g l1 l2 t} (SA : stack g (t:::l1+++l2)) : + stack g (l1+++t:::l2). Proof. simpl in SA. destruct SA as (x, S12). @@ -199,73 +423,97 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). - exact (x, S2). Defined. - Fixpoint comparable_data_to_data (a : comparable_type) (x : comparable_data a) : data a := + Fixpoint comparable_data_to_data g (a : comparable_type) (x : comparable_data a) : data g a := match a, x with - | Cpair a b, (x, y) => (x, comparable_data_to_data _ y) + | Cpair a b, (x, y) => (x, comparable_data_to_data g _ y) | Comparable_type_simple _, x => x end. - Fixpoint data_to_comparable_data (a : comparable_type) (x : data a) : comparable_data a := + Fixpoint data_to_comparable_data {g} (a : comparable_type) (x : data g a) : + comparable_data a := match a, x with | Cpair a b, (x, y) => (x, data_to_comparable_data _ y) | Comparable_type_simple _, x => x end. - Fixpoint concrete_data_to_data (a : type) (d : concrete_data a) : data a := - match d with - | Int_constant x => x - | Nat_constant x => x - | String_constant x => x - | Bytes_constant x => x - | Timestamp_constant x => x - | Signature_constant x => Mk_sig x - | Key_constant x => Mk_key x - | Key_hash_constant x => Mk_key_hash x - | Mutez_constant (Mk_mutez x) => x - | Address_constant x => x - | @Contract_constant a x H => exist _ x H - | Unit => tt - | True_ => true - | False_ => false - | Pair a b => (concrete_data_to_data _ a, concrete_data_to_data _ b) - | Left a => inl (concrete_data_to_data _ a) - | Right b => inr (concrete_data_to_data _ b) - | Some_ a => Some (concrete_data_to_data _ a) - | None_ => None - | Concrete_list l => List.map (concrete_data_to_data _) l - | @Concrete_set a l => - (fix concrete_data_set_to_data (l : Datatypes.list (concrete_data a)) := - match l with - | nil => set.empty _ _ - | cons x l => - set.insert - (comparable_data a) - (comparable.compare a) - (comparable.compare_eq_iff a) - (comparable.lt_trans a) - (comparable.gt_trans a) - (data_to_comparable_data _ (concrete_data_to_data a x)) - (concrete_data_set_to_data l) - end) l - | @Concrete_map a b l => - (fix concrete_data_map_to_data - (l : Datatypes.list (elt_pair (concrete_data a) (concrete_data b))) := - match l with - | nil => map.empty _ _ _ - | cons (Elt _ _ x y) l => - map.update - (comparable_data a) - (data b) - (comparable.compare a) - (comparable.compare_eq_iff a) - (comparable.lt_trans a) - (comparable.gt_trans a) - (data_to_comparable_data _ (concrete_data_to_data _ x)) - (Some (concrete_data_to_data _ y)) - (concrete_data_map_to_data l) - end) l - | Instruction tff i => existT _ _ i - | Chain_id_constant x => x + Fixpoint concrete_data_to_data g (a : type) (d : concrete_data a) : data g a + := + match d in (concrete_data t) return (data g t) with + | Int_constant z => z + | Nat_constant n => n + | String_constant s => s + | Bytes_constant s => s + | Timestamp_constant z => z + | Signature_constant s => Mk_sig s + | Key_constant s => Mk_key s + | Key_hash_constant s => Mk_key_hash s + | Mutez_constant (Mk_mutez m) => m + | Address_constant a => a + | Unit => tt + | True_ => true + | False_ => false + | Pair a b => (concrete_data_to_data g _ a, concrete_data_to_data g _ b) + | Left a _ _ => inl (concrete_data_to_data g _ a) + | Right b _ _ => inr (concrete_data_to_data g _ b) + | Some_ a => Some (concrete_data_to_data g _ a) + | None_ => None + | Concrete_list l => List.map (concrete_data_to_data g _) l + | @Concrete_set a l => + (fix concrete_data_set_to_data (l : Datatypes.list (concrete_data a)) := + match l with + | nil => set.empty _ _ + | cons x l => + set.insert + (comparable_data a) + (comparable.compare a) + (comparable.compare_eq_iff a) + (comparable.lt_trans a) + (comparable.gt_trans a) + (data_to_comparable_data _ (concrete_data_to_data g a x)) + (concrete_data_set_to_data l) + end) l + | @Concrete_map a b l => + (fix concrete_data_map_to_data + (l : Datatypes.list (elt_pair (concrete_data a) (concrete_data b))) := + match l with + | nil => map.empty _ _ _ + | cons (Elt _ _ x y) l => + map.update + (comparable_data a) + (data g b) + (comparable.compare a) + (comparable.compare_eq_iff a) + (comparable.lt_trans a) + (comparable.gt_trans a) + (data_to_comparable_data _ (concrete_data_to_data g _ x)) + (Some (concrete_data_to_data g _ y)) + (concrete_data_map_to_data l) + end) l + | @Concrete_big_map a b l => + (fix concrete_data_map_to_data + (l : Datatypes.list (elt_pair (concrete_data a) (concrete_data b))) := + match l with + | nil => map.empty _ _ _ + | cons (Elt _ _ x y) l => + map.update + (comparable_data a) + (data g b) + (comparable.compare a) + (comparable.compare_eq_iff a) + (comparable.lt_trans a) + (comparable.gt_trans a) + (data_to_comparable_data _ (concrete_data_to_data g _ x)) + (Some (concrete_data_to_data g _ y)) + (concrete_data_map_to_data l) + end) l + | @Instruction a0 b tff i => existT _ _ i + | Chain_id_constant c => c + end. + + Fixpoint stack_from_concrete {A} g (s : typed_concrete_stack A) : stack g A := + match A, s with + | nil, tt => tt + | cons a A, (x, s) => (concrete_data_to_data g a x, stack_from_concrete g s) end. @@ -289,7 +537,7 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). | Comparable_type_simple a, x => simple_comparable_data_to_concrete_data a x end. - Fixpoint data_to_concrete_data (a : type) (H : Is_true (is_packable a)) (x : data a) : + Fixpoint data_to_concrete_data {g} (a : type) (H : Is_true (is_packable a)) (x : data g a) : concrete_data a := match a, H, x with | Comparable_type b, _, x => comparable_data_to_concrete_data b x @@ -309,53 +557,54 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). (comparable_data_to_concrete_data _ k) (data_to_concrete_data b H v)) l) - | contract _, H, exist _ x Hx => - Contract_constant x Hx + | contract _, H, _ => match H with end | operation, H, _ => match H with end | big_map _ _, H, _ => match H with end | pair a b, H, (x, y) => Pair (data_to_concrete_data a (Is_true_and_left _ _ H) x) (data_to_concrete_data b (Is_true_and_right _ _ H) y) - | or a b, H, inl x => - Left (data_to_concrete_data a (Is_true_and_left _ _ H) x) - | or a b, H, inr x => - Right (data_to_concrete_data b (Is_true_and_right _ _ H) x) + | or a an b bn, H, inl x => + Left (data_to_concrete_data a (Is_true_and_left _ _ H) x) an bn + | or a an b bn, H, inr x => + Right (data_to_concrete_data b (Is_true_and_right _ _ H) x) an bn | lambda a b, _, existT _ tff f => Instruction tff f | chain_id, _, x => Chain_id_constant x end. - Definition or_fun a (v : bitwise_variant a) : data a -> data a -> data a := + Definition or_fun {g} a (v : bitwise_variant a) : data g a -> data g a -> data g a := match v with | Bitwise_variant_bool => orb | Bitwise_variant_nat => N.lor end. - Definition and a (v : bitwise_variant a) : data a -> data a -> data a := + Definition and {g} a b c (v : and_variant a b c) : data g a -> data g b -> data g c := match v with - | Bitwise_variant_bool => andb - | Bitwise_variant_nat => N.land + | And_variant_bool => andb + | And_variant_nat => N.land + | And_variant_int => + fun x y => Z.to_N (Z.land x (Z.of_N y)) end. - Definition xor a (v : bitwise_variant a) : data a -> data a -> data a := + Definition xor {g} a (v : bitwise_variant a) : data g a -> data g a -> data g a := match v with | Bitwise_variant_bool => xorb | Bitwise_variant_nat => N.lxor end. - Definition not a b (v : not_variant a b) : data a -> data b := + Definition not {g} a b (v : not_variant a b) : data g a -> data g b := match v with | Not_variant_bool => negb | Not_variant_int => fun x => (- 1 - x)%Z | Not_variant_nat => fun x => (- 1 - Z.of_N x)%Z end. - Definition neg a (v : neg_variant a) : data a -> data int := + Definition neg {g} a (v : neg_variant a) : data g a -> data g int := match v with | Neg_variant_nat => fun x => (- Z.of_N x)%Z | Neg_variant_int => fun x => (- x)%Z end. - Definition add a b c (v : add_variant a b c) : data a -> data b -> M (data c) := + Definition add {g} a b c (v : add_variant a b c) : data g a -> data g b -> M (data g c) := match v with | Add_variant_nat_nat => fun x y => Return (x + y)%N | Add_variant_nat_int => fun x y => Return (Z.of_N x + y)%Z @@ -388,11 +637,6 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). | Mul_variant_nat_tez => fun x y => tez.of_Z (Z.of_N x * tez.to_Z y) end. - Definition ediv_Z x y := - if (y =? 0)%Z then None else Some (x / y, Z.to_N (x mod y))%Z. - Definition ediv_N x y := - if (y =? 0)%N then None else Some (x / y, x mod y)%N. - Definition ediv a b c d (v : ediv_variant a b c d) : data a -> data b -> data (option (pair c d)) := match v with | Ediv_variant_nat_nat => fun x y => ediv_N x y @@ -550,285 +794,371 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). Definition data_to_string {a} (x : data a) : String.string := "". - (* The gas argument is used to ensure termination, it is not the - amount of gas that is actually required to run the contract because - in the SEQ case, both instructions are run with gas n *) + Definition contract_ (an : annot_o) (p : type) (x : data address) : data (option (contract p)). + Proof. + case_eq (get_address_type (x, an)). + - intros p' H. + simpl. + case (type_dec p p'). + + intro; subst p'. + apply Some. + eexists. + eassumption. + + intro; apply None. + - intro; apply None. + Defined. - Fixpoint eval {param_ty : Datatypes.option type} {tff0} (env : @proto_env param_ty) {A : stack_type} {B : stack_type} - (i : instruction param_ty tff0 A B) (fuel : Datatypes.nat) (SA : stack A) {struct fuel} : M (stack B) := - match fuel with - | O => Failed _ Out_of_fuel - | S n => - match i, SA, env with - | FAILWITH, (x, _), _ => - Failed _ (Assertion_Failure _ x) + Definition implicit_account (x : data key_hash) : data (contract unit). + Proof. + simpl. + exists (Implicit x, None). + reflexivity. + Defined. - (* According to the documentation, FAILWITH's argument should - not be part of the state reached by the instruction but the - whole point of this instruction (compared to the FAIL macro) - is to report the argument to the user. *) + Definition address_ a (x : data (contract a)) : data address := + match x with exist _ (addr, _) _ => addr end. - | NOOP, SA, _ => Return SA - | SEQ B C, SA, env => - let! r := eval env B n SA in - eval env C n r - | IF_ bt bf, (b, SA), env => - if b then eval env bt n SA else eval env bf n SA - | LOOP body, (b, SA), env => - if b then eval env (body;; (LOOP body)) n SA else Return SA - | LOOP_LEFT body, (ab, SA), env => - match ab with - | inl x => eval env (body;; LOOP_LEFT body) n (x, SA) - | inr y => Return (y, SA) - end - | EXEC, (x, (existT _ tff f, SA)), env => - let! (y, tt) := eval (no_self env) f n (x, tt) in - Return (y, SA) - | @APPLY _ a b c D i, (x, (existT _ _ f, SA)), env => + Definition eval_opcode param_ty (env : @proto_env param_ty) {A B : stack_type} + (o : @opcode param_ty A B) (SA : stack A) : M (stack B) := + match o, SA with + | @APPLY _ a b c D i, (x, (existT _ _ f, SA)) => Return (existT _ _ (PUSH _ (data_to_concrete_data _ i x) ;; PAIR ;; f), SA) - | DUP, (x, SA), _ => Return (x, (x, SA)) - | SWAP, (x, (y, SA)), _ => Return (y, (x, SA)) - | PUSH a x, SA, _ => Return (concrete_data_to_data _ x, SA) - | UNIT, SA, _ => Return (tt, SA) - | LAMBDA a b code, SA, _ => Return (existT _ _ code, SA) - | EQ, (x, SA), _ => Return ((x =? 0)%Z, SA) - | NEQ, (x, SA), _ => Return (negb (x =? 0)%Z, SA) - | LT, (x, SA), _ => Return ((x Return ((x >? 0)%Z, SA) - | LE, (x, SA), _ => Return ((x <=? 0)%Z, SA) - | GE, (x, SA), _ => Return ((x >=? 0)%Z, SA) - | @OR _ _ s, (x, (y, SA)), _ => + | DUP, (x, SA) => Return (x, (x, SA)) + | SWAP, (x, (y, SA)) => Return (y, (x, SA)) + | UNIT, SA => Return (tt, SA) + | EQ, (x, SA) => Return ((x =? 0)%Z, SA) + | NEQ, (x, SA) => Return (negb (x =? 0)%Z, SA) + | LT, (x, SA) => Return ((x Return ((x >? 0)%Z, SA) + | LE, (x, SA) => Return ((x <=? 0)%Z, SA) + | GE, (x, SA) => Return ((x >=? 0)%Z, SA) + | @OR _ _ s, (x, (y, SA)) => Return (or_fun _ (bitwise_variant_field _ s) x y, SA) - | @AND _ _ s, (x, (y, SA)), _ => - Return (and _ (bitwise_variant_field _ s) x y, SA) - | @XOR _ _ s, (x, (y, SA)), _ => + | @AND _ _ _ s, (x, (y, SA)) => + Return (and _ _ _ (and_variant_field _ _ s) x y, SA) + | @XOR _ _ s, (x, (y, SA)) => Return (xor _ (bitwise_variant_field _ s) x y, SA) - | @NOT _ _ s, (x, SA), _ => Return (not _ _ (not_variant_field _ s) x, SA) - | @NEG _ _ s, (x, SA), _ => Return (neg _ (neg_variant_field _ s) x, SA) - | ABS, (x, SA), _ => Return (Z.abs_N x, SA) - | ISNAT, (x, SA), _ => + | @NOT _ _ s, (x, SA) => Return (not _ _ (not_variant_field _ s) x, SA) + | @NEG _ _ s, (x, SA) => Return (neg _ (neg_variant_field _ s) x, SA) + | ABS, (x, SA) => Return (Z.abs_N x, SA) + | ISNAT, (x, SA) => Return (if (x >=? 0)%Z then (Some (Z.to_N x), SA) else (None, SA)) - | INT, (x, SA), _ => Return (Z.of_N x, SA) - | @ADD _ _ _ s, (x, (y, SA)), _ => + | INT, (x, SA) => Return (Z.of_N x, SA) + | @ADD _ _ _ s, (x, (y, SA)) => let! r := add _ _ _ (add_variant_field _ _ s) x y in Return (r, SA) - | @SUB _ _ _ s, (x, (y, SA)), _ => + | @SUB _ _ _ s, (x, (y, SA)) => let! r := sub _ _ _ (sub_variant_field _ _ s) x y in Return (r, SA) - | @MUL _ _ _ s, (x, (y, SA)), _ => + | @MUL _ _ _ s, (x, (y, SA)) => let! r := mul _ _ _ (mul_variant_field _ _ s) x y in Return (r, SA) - | @EDIV _ _ _ s, (x, (y, SA)), _ => + | @EDIV _ _ _ s, (x, (y, SA)) => Return (ediv _ _ _ _ (ediv_variant_field _ _ s) x y, SA) - | LSL, (x, (y, SA)), _ => Return (N.shiftl x y, SA) - | LSR, (x, (y, SA)), _ => Return (N.shiftr x y, SA) - | COMPARE, (x, (y, SA)), _ => + | LSL, (x, (y, SA)) => Return (N.shiftl x y, SA) + | LSR, (x, (y, SA)) => Return (N.shiftr x y, SA) + | COMPARE, (x, (y, SA)) => Return (comparison_to_int (compare _ (data_to_comparable_data _ x) (data_to_comparable_data _ y)), SA) - | @CONCAT _ _ s _, (x, (y, SA)), _ => + | @CONCAT _ _ s _, (x, (y, SA)) => Return (concat _ (stringlike_variant_field _ s) x y, SA) - | @CONCAT_list _ _ s _, (l, SA), _ => + | @CONCAT_list _ _ s _, (l, SA) => Return (concat_list _ (stringlike_variant_field _ s) l, SA) - | @SLICE _ _ i, (n1, (n2, (s, SA))), _ => + | @SLICE _ _ i, (n1, (n2, (s, SA))) => Return (slice _ (stringlike_variant_field _ i) n1 n2 s, SA) - | PAIR, (x, (y, SA)), _ => Return ((x, y), SA) - | CAR, ((x, y), SA), _ => Return (x, SA) - | CDR, ((x, y), SA), _ => Return (y, SA) - | EMPTY_SET a, SA, _ => Return (set.empty _ (compare a), SA) - | @MEM _ _ _ s _, (x, (y, SA)), _ => + | PAIR, (x, (y, SA)) => Return ((x, y), SA) + | CAR, ((x, y), SA) => Return (x, SA) + | CDR, ((x, y), SA) => Return (y, SA) + | EMPTY_SET a, SA => Return (set.empty _ (compare a), SA) + | @MEM _ _ _ s _, (x, (y, SA)) => Return (mem _ _ (mem_variant_field _ _ s) (data_to_comparable_data _ x) y, SA) - | @UPDATE _ _ _ _ s _, (x, (y, (z, SA))), _ => + | @UPDATE _ _ _ _ s _, (x, (y, (z, SA))) => Return (update _ _ _ (update_variant_field _ _ _ s) (data_to_comparable_data _ x) y z, SA) - | @ITER _ _ s _ body, (x, SA), env => - match iter_destruct _ _ (iter_variant_field _ s) x with - | None => Return SA - | Some (a, y) => - let! SB := eval env body n (a, SA) in - eval env (ITER body) n (y, SB) - end - | @SIZE _ _ s, (x, SA), _ => + | @SIZE _ _ s, (x, SA) => Return (N.of_nat (size _ (size_variant_field _ s) x), SA) - | EMPTY_MAP k val, SA, _ => + | EMPTY_MAP k val, SA => Return (map.empty (comparable_data k) (data val) _, SA) - | EMPTY_BIG_MAP k val, SA, _ => + | EMPTY_BIG_MAP k val, SA => Return (map.empty (comparable_data k) (data val) _, SA) - | @GET _ _ _ s _, (x, (y, SA)), _ => + | @GET _ _ _ s _, (x, (y, SA)) => Return (get _ _ _ (get_variant_field _ _ s) (data_to_comparable_data _ x) y, SA) + | SOME, (x, SA) => Return (Some x, SA) + | NONE _, SA => Return (None, SA) + | LEFT _, (x, SA) => Return (inl x, SA) + | RIGHT _, (x, SA) => Return (inr x, SA) + | CONS, (x, (y, SA)) => Return (cons x y, SA) + | NIL _, SA => Return (nil, SA) + | TRANSFER_TOKENS, (a, (b, (c, SA))) => + Return (transfer_tokens env _ a b c, SA) + | SET_DELEGATE, (x, SA) => Return (set_delegate env x, SA) + | BALANCE, SA => Return (balance env, SA) + | ADDRESS, (x, SA) => Return (address_ _ x, SA) + | CONTRACT ao p, (x, SA) => Return (contract_ ao p x, SA) + | SOURCE, SA => Return (source env, SA) + | SENDER, SA => Return (sender env, SA) + | AMOUNT, SA => Return (amount env, SA) + | IMPLICIT_ACCOUNT, (x, SA) => Return (implicit_account x, SA) + | NOW, SA => Return (now env, SA) + | PACK, (x, SA) => Return (pack env _ x, SA) + | UNPACK ty, (x, SA) => Return (unpack env ty x, SA) + | HASH_KEY, (x, SA) => Return (hash_key env x, SA) + | BLAKE2B, (x, SA) => Return (blake2b env x, SA) + | SHA256, (x, SA) => Return (sha256 env x, SA) + | SHA512, (x, SA) => Return (sha512 env x, SA) + | CHECK_SIGNATURE, (x, (y, (z, SA))) => + Return (check_signature env x y z, SA) + | DIG n Hlen, SA => Return (stack_dig SA) + | DUG n Hlen, SA => Return (stack_dug SA) + | DROP n Hlen, SA => + let (S1, S2) := stack_split SA in Return S2 + | CHAIN_ID, SA => Return (chain_id_ env, SA) + end. + + Definition if_family_destruct {A B t} (i : if_family A B t) (x : data t) : stack A + stack B := + match i, x with + | IF_bool, true => inl tt + | IF_bool, false => inr tt + | IF_or _ _ _ _, inl x => inl (x, tt) + | IF_or _ _ _ _, inr x => inr (x, tt) + | IF_option a, None => inl tt + | IF_option a, Some x => inr (x, tt) + | IF_list a, cons x l => inl (x, (l, tt)) + | IF_list a, nil => inr tt + end. + + Definition loop_family_destruct {A B t} (i : loop_family A B t) (x : data t) : stack A + stack B := + match i, x with + | LOOP_bool, true => inl tt + | LOOP_bool, false => inr tt + | LOOP_or _ _ _ _, inl x => inl (x, tt) + | LOOP_or _ _ _ _, inr x => inr (x, tt) + end. + + Fixpoint eval_seq_body + (eval : forall param_ty tff0 (env : @proto_env param_ty) A B, instruction param_ty tff0 A B -> stack A -> M (stack B)) + {param_ty : self_info} {tff0} (env : @proto_env param_ty) {A : stack_type} {B : stack_type} + (i : instruction_seq param_ty tff0 A B) (SA : stack A) {struct i} : M (stack B) := + match i, SA, env with + | NOOP, SA, _ => Return SA + | Tail_fail i, SA, env => eval _ _ env _ _ i SA + | SEQ B C, SA, env => + let! r := eval _ _ env _ _ B SA in + eval_seq_body eval env C r + end. + + Fixpoint eval {param_ty : self_info} {tff0} (env : @proto_env param_ty) {A : stack_type} {B : stack_type} + (i : instruction param_ty tff0 A B) (fuel : Datatypes.nat) (SA : stack A) {struct fuel} : M (stack B) := + match fuel with + | O => Failed _ Out_of_fuel + | S n => + let eval_n {param_ty : self_info} {tff0} (env : @proto_env param_ty) + {A : stack_type} {B : stack_type} (i : instruction param_ty tff0 A B) + (SA : stack A) : M (stack B) := + eval env i n SA in + match i, SA, env with + | Instruction_seq i, SA, env => + eval_seq_body (@eval_n) env i SA + | FAILWITH, (x, _), _ => + Failed _ (Assertion_Failure _ x) + + (* According to the documentation, FAILWITH's argument should + not be part of the state reached by the instruction but the + whole point of this instruction (compared to the FAIL macro) + is to report the argument to the user. *) + + | IF_ f bt bf, (x, SA), env => + match if_family_destruct f x with + | inl SB => eval_seq_body (@eval_n) env bt (stack_app SB SA) + | inr SB => eval_seq_body (@eval_n) env bf (stack_app SB SA) + end + | LOOP_ f body, (ab, SA), env => + match loop_family_destruct f ab with + | inl SB => + let! SC := eval_seq_body (@eval_n) env body (stack_app SB SA) in + eval_n env (LOOP_ f body) SC + | inr SB => Return (stack_app SB SA) + end + | PUSH a x, SA, _ => Return (concrete_data_to_data _ x, SA) + | LAMBDA a b code, SA, _ => Return (existT _ _ code, SA) + | @ITER _ _ s _ body, (x, SA), env => + match iter_destruct _ _ (iter_variant_field _ s) x with + | None => Return SA + | Some (a, y) => + let! SB := eval_seq_body (@eval_n) env body (a, SA) in + eval_n env (ITER body) (y, SB) + end | @MAP _ _ _ s _ body, (x, SA), env => let v := (map_variant_field _ _ s) in match map_destruct _ _ _ _ v x with | None => Return (map_empty _ _ _ _ v, SA) | Some (a, y) => - let! (b, SB) := eval env body n (a, SA) in - let! (c, SC) := eval env (MAP body) n (y, SB) in + let! (b, SB) := eval_seq_body (@eval_n) env body (a, SA) in + let! (c, SC) := eval_n env (MAP body) (y, SB) in Return (map_insert _ _ _ _ v a b c, SC) end - | SOME, (x, SA), _ => Return (Some x, SA) - | NONE _, SA, _ => Return (None, SA) - | IF_NONE bt bf, (b, SA), env => - match b with - | None => eval env bt n SA - | Some b => eval env bf n (b, SA) - end - | LEFT _, (x, SA), _ => Return (inl x, SA) - | RIGHT _, (x, SA), _ => Return (inr x, SA) - | IF_LEFT bt bf, (b, SA), env => - match b with - | inl a => eval env bt n (a, SA) - | inr b => eval env bf n (b, SA) - end - | CONS, (x, (y, SA)), _ => Return (cons x y, SA) - | NIL _, SA, _ => Return (nil, SA) - | IF_CONS bt bf, (l, SA), env => - match l with - | cons a b => eval env bt n (a, (b, SA)) - | nil => eval env bf n SA - end - | CREATE_CONTRACT _ _ f, (a, (b, (c, SA))), env => - let (oper, addr) := create_contract env _ _ _ a b f c in + | CREATE_CONTRACT g p an f, (a, (b, (c, SA))), env => + let (oper, addr) := create_contract env g p an _ a b f c in Return (oper, (addr, SA)) - | TRANSFER_TOKENS, (a, (b, (c, SA))), env => - Return (transfer_tokens env _ a b c, SA) - | SET_DELEGATE, (x, SA), env => Return (set_delegate env x, SA) - | BALANCE, SA, env => Return (balance env, SA) - | ADDRESS, (x, SA), env => Return (address_ env _ x, SA) - | CONTRACT _, (x, SA), env => Return (contract_ env _ x, SA) - | SOURCE, SA, env => Return (source env, SA) - | SENDER, SA, env => Return (sender env, SA) - | SELF, SA, env => Return (self env, SA) - | AMOUNT, SA, env => Return (amount env, SA) - | IMPLICIT_ACCOUNT, (x, SA), env => Return (implicit_account env x, SA) - | NOW, SA, env => Return (now env, SA) - | PACK, (x, SA), env => Return (pack env _ x, SA) - | UNPACK ty, (x, SA), env => Return (unpack env ty x, SA) - | HASH_KEY, (x, SA), env => Return (hash_key env x, SA) - | BLAKE2B, (x, SA), env => Return (blake2b env x, SA) - | SHA256, (x, SA), env => Return (sha256 env x, SA) - | SHA512, (x, SA), env => Return (sha512 env x, SA) - | CHECK_SIGNATURE, (x, (y, (z, SA))), env => - Return (check_signature env x y z, SA) - | DIG n Hlen, SA, _ => Return (stack_dig SA) - | DUG n Hlen, SA, _ => Return (stack_dug SA) + | SELF ao H, SA, env => Return (self env ao H, SA) + | EXEC, (x, (existT _ tff f, SA)), env => + let! (y, tt) := eval_seq_body (@eval_n) (no_self env) f (x, tt) in + Return (y, SA) | DIP nl Hlen i, SA, env => let (S1, S2) := stack_split SA in - let! S3 := eval env i n S2 in + let! S3 := eval_seq_body (@eval_n) env i S2 in Return (stack_app S1 S3) - | DROP n Hlen, SA, _ => - let (S1, S2) := stack_split SA in Return S2 - | CHAIN_ID, SA, env => Return (chain_id_ env, SA) + | Instruction_opcode o, SA, env => + eval_opcode _ env o SA end end. + Definition eval_seq + {param_ty : self_info} {tff0} (env : @proto_env param_ty) {A : stack_type} {B : stack_type} + (i : instruction_seq param_ty tff0 A B) (fuel : Datatypes.nat) (SA : stack A) : M (stack B) := + eval_seq_body (fun param_ty tff env A B i SA => eval env i fuel SA) env i SA. + + Lemma eval_seq_deterministic_le_aux + (eval1 eval2 : forall param_ty tff (env : @proto_env param_ty) A B, instruction param_ty tff A B -> stack A -> M (stack B)) + (H : forall param_ty env tff A B (i : instruction param_ty tff A B) st, + success (eval1 param_ty tff env A B i st) -> + eval1 param_ty tff env A B i st = eval2 param_ty tff env A B i st) : + forall param_ty env tff A B (i : instruction_seq param_ty tff A B) st, + success (eval_seq_body eval1 env i st) -> + eval_seq_body eval1 env i st = + eval_seq_body eval2 env i st. + Proof. + intros param_ty env tff A B i. + induction i; simpl; auto. + intros st Hsucc. + destruct (success_bind _ _ Hsucc) as (x, (H1, H2)). + rewrite <- H. + - rewrite H1. + simpl. + apply IHi. + exact H2. + - rewrite H1. + constructor. + Qed. + (* The evaluator does not depend on the amount of fuel provided *) - Lemma eval_deterministic_le : - forall fuel1 fuel2, + Fixpoint eval_deterministic_le fuel1 : + forall fuel2, fuel1 <= fuel2 -> forall {self_type env tff0 A B} (i : instruction self_type tff0 A B) st, success (eval env i fuel1 st) -> eval env i fuel1 st = eval env i fuel2 st. Proof. - induction fuel1; intros fuel2 Hle self_type env tff0 A B i st Hsucc. - - contradiction. - - destruct fuel2. - + inversion Hle. - + apply le_S_n in Hle. - specialize (IHfuel1 fuel2 Hle). - simpl. - destruct i; try reflexivity. - * simpl in Hsucc. - destruct (success_bind _ _ Hsucc) as (x, (H1, H2)). - rewrite <- IHfuel1. - -- rewrite H1. - simpl. - apply IHfuel1. - assumption. - -- apply success_eq_return in H1. - exact H1. - * destruct st as ([], st); rewrite IHfuel1; try assumption; reflexivity. - * destruct st as ([], st). - -- rewrite IHfuel1; try assumption; reflexivity. - -- reflexivity. - * destruct st as ([x|y], st). - -- rewrite IHfuel1; try assumption; reflexivity. - -- reflexivity. - * destruct st as (x, ((tff, f), SA)). - f_equal. - rewrite IHfuel1. - -- reflexivity. - -- simpl in Hsucc. - apply success_bind_arg in Hsucc. - assumption. - * destruct st as (x, SA). - generalize Hsucc; clear Hsucc. + { + destruct fuel1; intros fuel2 Hle self_type env tff0 A B i st Hsucc. + - contradiction. + - destruct fuel2. + + inversion Hle. + + apply le_S_n in Hle. + pose (eval1 := fun param_ty tff env A B (i : instruction param_ty tff A B) st => eval env i fuel1 st). + pose (eval2 := fun param_ty tff env A B (i : instruction param_ty tff A B) st => eval env i fuel2 st). + assert (forall param_ty env tff A B (i : instruction param_ty tff A B) st, + success (eval1 param_ty tff env A B i st) -> + eval1 param_ty tff env A B i st = eval2 param_ty tff env A B i st) as Heval12 by (apply eval_deterministic_le; assumption). + specialize (eval_seq_deterministic_le_aux eval1 eval2 Heval12); intro Haux. simpl. - destruct (iter_destruct (iter_elt_type collection i) collection - (iter_variant_field collection i) x). - -- destruct d. - fold stack. - intro Hsucc. - rewrite <- IHfuel1. - ++ destruct (success_bind _ _ Hsucc) as (SB, (Ha, Hb)). - rewrite Ha. - simpl. - apply IHfuel1. - assumption. - ++ apply success_bind_arg in Hsucc. - assumption. - -- reflexivity. - * destruct st as (x, SA). - generalize Hsucc; clear Hsucc. - simpl. - fold stack. - destruct (map_destruct (map_in_type collection b i) - b - collection - (map_out_collection_type collection b i) - (map_variant_field collection b i) x). - -- destruct d. - intro Hsucc. - rewrite <- IHfuel1. - ++ destruct (success_bind _ _ Hsucc) as ((c, SC), (Ha, Hb)). - destruct (success_bind _ _ Hb) as ((dd, SD), (Hm, _)). - rewrite Ha. - simpl. - rewrite <- IHfuel1. - ** reflexivity. - ** rewrite Hm. - constructor. - ++ apply success_bind_arg in Hsucc. - assumption. - -- reflexivity. - * destruct st as ([|], SA); rewrite IHfuel1. - -- reflexivity. - -- exact Hsucc. - -- reflexivity. - -- exact Hsucc. - * destruct st as ([|], SA); rewrite IHfuel1. - -- reflexivity. - -- exact Hsucc. - -- reflexivity. - -- exact Hsucc. - * destruct st as ([|], SA); rewrite IHfuel1. - -- reflexivity. - -- exact Hsucc. - -- reflexivity. - -- exact Hsucc. - * simpl in Hsucc. - destruct (stack_split st); rewrite IHfuel1. - -- reflexivity. - -- destruct (success_bind _ _ Hsucc) as (x, (H1, H2)). - apply success_eq_return in H1. - exact H1. + destruct i; try reflexivity. + * apply Haux; assumption. + * simpl in Hsucc. + destruct st as (x, st); destruct (if_family_destruct _ x) as [SB|SB]; + rewrite Haux; try assumption; reflexivity. + * simpl in Hsucc. + destruct st as (x, st); destruct (loop_family_destruct _ x) as [SB|SB]; clear x. + -- apply success_bind in Hsucc. + destruct Hsucc as ((x, stA), (H1, H2)). + change (fun param_ty tff0 env A B i SA => eval env i fuel1 SA) with eval1 in H1. + change (fun param_ty tff0 env A B i SA => eval env i fuel1 SA) with eval1. + change (fun param_ty tff0 env A B i SA => eval env i fuel2 SA) with eval2. + rewrite <- Haux; try assumption. + ++ rewrite H1. + simpl. + apply eval_deterministic_le; assumption. + ++ rewrite H1. + constructor. + -- reflexivity. + * destruct st as (x, SA). + generalize Hsucc; clear Hsucc. + simpl. + destruct (iter_destruct (iter_elt_type collection i) collection + (iter_variant_field collection i) x). + -- destruct d. + change (fun param_ty tff0 env A B i SA => eval env i fuel1 SA) with eval1. + change (fun param_ty tff0 env A B i SA => eval env i fuel2 SA) with eval2. + intro Hsucc. + rewrite <- Haux. + ++ destruct (success_bind _ _ Hsucc) as (SB, (Ha, Hb)). + rewrite Ha. + simpl. + apply eval_deterministic_le; assumption. + ++ apply success_bind_arg in Hsucc. + assumption. + -- reflexivity. + * destruct st as (x, SA). + generalize Hsucc; clear Hsucc. + simpl. + fold stack. + destruct (map_destruct (map_in_type collection b i) + b + collection + (map_out_collection_type collection b i) + (map_variant_field collection b i) x). + -- destruct d. + change (fun param_ty tff0 env A B i SA => eval env i fuel1 SA) with eval1. + change (fun param_ty tff0 env A B i SA => eval env i fuel2 SA) with eval2. + intro Hsucc. + rewrite <- Haux; try assumption. + ++ destruct (success_bind _ _ Hsucc) as ((c, SC), (Ha, Hb)). + destruct (success_bind _ _ Hb) as ((dd, SD), (Hm, _)). + rewrite Ha. + simpl. + rewrite <- (eval_deterministic_le fuel1 fuel2); try assumption. + ** reflexivity. + ** rewrite Hm. + constructor. + ++ apply success_bind_arg in Hsucc. + assumption. + -- reflexivity. + * destruct st as (x, ((tff, f), SA)). + f_equal. + rewrite Haux; try assumption. + -- reflexivity. + -- simpl in Hsucc. + apply success_bind_arg in Hsucc. + assumption. + * simpl in Hsucc. + destruct (stack_split st); rewrite Haux; try assumption. + -- reflexivity. + -- destruct (success_bind _ _ Hsucc) as (x, (H1, H2)). + apply success_eq_return in H1. + exact H1. + } + Qed. + + Lemma eval_seq_deterministic_le fuel1 fuel2 : + fuel1 <= fuel2 -> + forall {self_type env tff0 A B} (i : instruction_seq self_type tff0 A B) st, + success (eval_seq env i fuel1 st) -> + eval_seq env i fuel1 st = eval_seq env i fuel2 st. + Proof. + pose (eval1 := fun param_ty tff env A B (i : instruction param_ty tff A B) st => eval env i fuel1 st). + pose (eval2 := fun param_ty tff env A B (i : instruction param_ty tff A B) st => eval env i fuel2 st). + intro H. + apply (eval_seq_deterministic_le_aux eval1 eval2). + apply eval_deterministic_le; assumption. Qed. Lemma eval_deterministic_success_both {self_type env} fuel1 fuel2 {A B tff0} (i : instruction self_type tff0 A B) S : @@ -845,41 +1175,14 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). apply eval_deterministic_le; assumption. Qed. - Definition eval_precond_body - (eval_precond_n : forall {self_type}, - @proto_env self_type -> - forall {tff0 A B}, - instruction self_type tff0 A B -> - (stack B -> Prop) -> stack A -> Prop) - {self_type} env tff0 A B - (i : instruction self_type tff0 A B) - (psi : stack B -> Prop) - (SA : stack A) : Prop := - match i, env, psi, SA with - | FAILWITH, _, _, _ => false - | NOOP, env, psi, st => psi st - | SEQ B C, env, psi, st => - eval_precond_n env B (eval_precond_n env C psi) st - | IF_ bt bf, env, psi, (b, SA) => - if b then eval_precond_n env bt psi SA - else eval_precond_n env bf psi SA - | LOOP body, env, psi, (b, SA) => - if b then eval_precond_n env (body;; (LOOP body)) psi SA - else psi SA - | LOOP_LEFT body, env, psi, (ab, SA) => - match ab with - | inl x => eval_precond_n env (body;; LOOP_LEFT body) psi (x, SA) - | inr y => psi (y, SA) - end - | EXEC, env, psi, (x, (existT _ _ f, SA)) => - eval_precond_n (no_self env) f (fun '(y, tt) => psi (y, SA)) (x, tt) + Definition eval_precond_opcode {self_type} (env : @proto_env self_type) + A B (o : @opcode self_type A B) (psi : stack B -> Prop) (SA : stack A) : Prop := + match o, env, psi, SA with | @APPLY _ a b c D i, env, psi, (x, (existT _ _ f, SA)) => - psi (existT _ _ (PUSH _ (data_to_concrete_data _ i x) ;; PAIR ;; f), SA) + psi (existT _ _ (PUSH _ (data_to_concrete_data _ i x) ;; Instruction_opcode PAIR ;; f), SA) | DUP, env, psi, (x, SA) => psi (x, (x, SA)) | SWAP, env, psi, (x, (y, SA)) => psi (y, (x, SA)) - | PUSH a x, env, psi, SA => psi (concrete_data_to_data _ x, SA) | UNIT, env, psi, SA => psi (tt, SA) - | LAMBDA a b code, env, psi, SA => psi (existT _ _ code, SA) | EQ, env, psi, (x, SA) => psi ((x =? 0)%Z, SA) | NEQ, env, psi, (x, SA) => psi (negb (x =? 0)%Z, SA) | LT, env, psi, (x, SA) => psi ((x psi ((x <=? 0)%Z, SA) | GE, env, psi, (x, SA) => psi ((x >=? 0)%Z, SA) | @OR _ _ s _, env, psi, (x, (y, SA)) => psi (or_fun _ (bitwise_variant_field _ s) x y, SA) - | @AND _ _ s _, env, psi, (x, (y, SA)) => psi (and _ (bitwise_variant_field _ s) x y, SA) + | @AND _ _ _ s _, env, psi, (x, (y, SA)) => psi (and _ _ _ (and_variant_field _ _ s) x y, SA) | @XOR _ _ s _, env, psi, (x, (y, SA)) => psi (xor _ (bitwise_variant_field _ s) x y, SA) | @NOT _ _ s _, env, psi, (x, SA) => psi (not _ _ (not_variant_field _ s) x, SA) | @NEG _ _ s _, env, psi, (x, SA) => psi (neg _ (neg_variant_field _ s) x, SA) @@ -919,69 +1222,27 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). psi (mem _ _ (mem_variant_field _ _ s) (data_to_comparable_data _ x) y, SA) | @UPDATE _ _ _ _ s _, env, psi, (x, (y, (z, SA))) => psi (update _ _ _ (update_variant_field _ _ _ s) (data_to_comparable_data _ x) y z, SA) - | @ITER _ _ s _ body, env, psi, (x, SA) => - match iter_destruct _ _ (iter_variant_field _ s) x with - | None => psi SA - | Some (a, y) => - eval_precond_n - env body - (fun SB => eval_precond_n env (ITER body) psi (y, SB)) - (a, SA) - end | @SIZE _ _ s, env, psi, (x, SA) => psi (N.of_nat (size _ (size_variant_field _ s) x), SA) | EMPTY_MAP k val, env, psi, SA => psi (map.empty (comparable_data k) (data val) _, SA) | EMPTY_BIG_MAP k val, env, psi, SA => psi (map.empty (comparable_data k) (data val) _, SA) | @GET _ _ _ s _, env, psi, (x, (y, SA)) => psi (get _ _ _ (get_variant_field _ _ s) (data_to_comparable_data _ x) y, SA) - | @MAP _ _ _ s _ body, env, psi, (x, SA) => - let v := (map_variant_field _ _ s) in - match map_destruct _ _ _ _ v x with - | None => psi (map_empty _ _ _ _ v, SA) - | Some (a, y) => - eval_precond_n - env body - (fun '(b, SB) => - eval_precond_n - env (MAP body) - (fun '(c, SC) => psi (map_insert _ _ _ _ v a b c, SC)) - (y, SB)) - (a, SA) - end | SOME, env, psi, (x, SA) => psi (Some x, SA) | NONE _, env, psi, SA => psi (None, SA) - | IF_NONE bt bf, env, psi, (b, SA) => - match b with - | None => eval_precond_n env bt psi SA - | Some b => eval_precond_n env bf psi (b, SA) - end | LEFT _, env, psi, (x, SA) => psi (inl x, SA) | RIGHT _, env, psi, (x, SA) => psi (inr x, SA) - | IF_LEFT bt bf, env, psi, (b, SA) => - match b with - | inl a => eval_precond_n env bt psi (a, SA) - | inr b => eval_precond_n env bf psi (b, SA) - end | CONS, env, psi, (x, (y, SA)) => psi (cons x y, SA) | NIL _, env, psi, SA => psi (nil, SA) - | IF_CONS bt bf, env, psi, (l, SA) => - match l with - | cons a b => eval_precond_n env bt psi (a, (b, SA)) - | nil => eval_precond_n env bf psi SA - end - | CREATE_CONTRACT _ _ f, env, psi, (a, (b, (c, SA))) => - let (oper, addr) := create_contract env _ _ _ a b f c in - psi (oper, (addr, SA)) | TRANSFER_TOKENS, env, psi, (a, (b, (c, SA))) => psi (transfer_tokens env _ a b c, SA) | SET_DELEGATE, env, psi, (x, SA) => psi (set_delegate env x, SA) | BALANCE, env, psi, SA => psi (balance env, SA) - | ADDRESS, env, psi, (x, SA) => psi (address_ env _ x, SA) - | CONTRACT _, env, psi, (x, SA) => psi (contract_ env _ x, SA) + | ADDRESS, env, psi, (x, SA) => psi (address_ _ x, SA) + | CONTRACT ao p, env, psi, (x, SA) => psi (contract_ ao p x, SA) | SOURCE, env, psi, SA => psi (source env, SA) | SENDER, env, psi, SA => psi (sender env, SA) - | SELF, env, psi, SA => psi (self env, SA) | AMOUNT, env, psi, SA => psi (amount env, SA) - | IMPLICIT_ACCOUNT, env, psi, (x, SA) => psi (implicit_account env x, SA) + | IMPLICIT_ACCOUNT, env, psi, (x, SA) => psi (implicit_account x, SA) | NOW, env, psi, SA => psi (now env, SA) | PACK, env, psi, (x, SA) => psi (pack env _ x, SA) | UNPACK ty, env, psi, (x, SA) => psi (unpack env ty x, SA) @@ -993,14 +1254,94 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). psi (check_signature env x y z, SA) | DIG n Hlen, env, psi, st => psi (stack_dig st) | DUG n Hlen, env, psi, st => psi (stack_dug st) - | DIP n Hlen i, env, psi, SA => - let (S1, S2) := stack_split SA in - eval_precond_n env i (fun SB => psi (stack_app S1 SB)) S2 | DROP n Hlen, env, psi, SA => let (S1, S2) := stack_split SA in psi S2 | CHAIN_ID, env, psi, SA => psi (chain_id_ env, SA) end. + Fixpoint eval_seq_precond_body + (eval_precond_n : forall {self_type}, + @proto_env self_type -> + forall {tff0 A B}, + instruction self_type tff0 A B -> + (stack B -> Prop) -> stack A -> Prop) + {self_type} env tff0 A B + (i : instruction_seq self_type tff0 A B) + (psi : stack B -> Prop) + (SA : stack A) : Prop := + match i, env, psi, SA with + | NOOP, env, psi, st => psi st + | SEQ B C, env, psi, st => + eval_precond_n env B (@eval_seq_precond_body (@eval_precond_n) _ env _ _ _ C psi) st + | Tail_fail i, env, psi, st => + eval_precond_n env i psi st + end. + + Definition eval_precond_body + (eval_precond_n : forall {self_type}, + @proto_env self_type -> + forall {tff0 A B}, + instruction self_type tff0 A B -> + (stack B -> Prop) -> stack A -> Prop) + {self_type} env tff0 A B + (i : instruction self_type tff0 A B) + (psi : stack B -> Prop) + (SA : stack A) : Prop := + match i, env, psi, SA with + | Instruction_seq i, env, psi, SA => + eval_seq_precond_body (@eval_precond_n) env _ _ _ i psi SA + | FAILWITH, _, _, _ => false + | IF_ f bt bf, env, psi, (x, SA) => + match (if_family_destruct f x) with + | inl SB => eval_seq_precond_body (@eval_precond_n) env _ _ _ bt psi (stack_app SB SA) + | inr SB => eval_seq_precond_body (@eval_precond_n) env _ _ _ bf psi (stack_app SB SA) + end + | LOOP_ f body, env, psi, (x, SA) => + match (loop_family_destruct f x) with + | inl SB => + eval_seq_precond_body (@eval_precond_n) env _ _ _ body + (eval_precond_n env (LOOP_ f body) psi) + (stack_app SB SA) + | inr SB => psi (stack_app SB SA) + end + | EXEC, env, psi, (x, (existT _ _ f, SA)) => + eval_seq_precond_body (@eval_precond_n) (no_self env) _ _ _ f (fun '(y, tt) => psi (y, SA)) (x, tt) + | PUSH a x, env, psi, SA => psi (concrete_data_to_data _ x, SA) + | LAMBDA a b code, env, psi, SA => psi (existT _ _ code, SA) + | @ITER _ _ s _ body, env, psi, (x, SA) => + match iter_destruct _ _ (iter_variant_field _ s) x with + | None => psi SA + | Some (a, y) => + eval_seq_precond_body (@eval_precond_n) + env _ _ _ body + (fun SB => eval_precond_n env (ITER body) psi (y, SB)) + (a, SA) + end + | @MAP _ _ _ s _ body, env, psi, (x, SA) => + let v := (map_variant_field _ _ s) in + match map_destruct _ _ _ _ v x with + | None => psi (map_empty _ _ _ _ v, SA) + | Some (a, y) => + eval_seq_precond_body (@eval_precond_n) + env _ _ _ body + (fun '(b, SB) => + eval_precond_n + env (MAP body) + (fun '(c, SC) => psi (map_insert _ _ _ _ v a b c, SC)) + (y, SB)) + (a, SA) + end + | CREATE_CONTRACT g p an f, env, psi, (a, (b, (c, SA))) => + let (oper, addr) := create_contract env g p an _ a b f c in + psi (oper, (addr, SA)) + | SELF ao H, env, psi, SA => psi (self env ao H, SA) + | DIP n Hlen i, env, psi, SA => + let (S1, S2) := stack_split SA in + eval_seq_precond_body (@eval_precond_n) env _ _ _ i (fun SB => psi (stack_app S1 SB)) S2 + | Instruction_opcode o, env, psi, SA => + eval_precond_opcode env _ _ o psi SA + end. + Fixpoint eval_precond (fuel : Datatypes.nat) : forall {self_type} env {tff0 A B}, instruction self_type tff0 A B -> @@ -1011,88 +1352,82 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). @eval_precond_body (@eval_precond n) end. + Definition eval_seq_precond (fuel : Datatypes.nat) : + forall {self_type} env {tff0 A B}, + instruction_seq self_type tff0 A B -> + (stack B -> Prop) -> (stack A -> Prop) := + @eval_seq_precond_body (@eval_precond fuel). + + Lemma eval_precond_opcode_correct {sty env A B} (o : opcode A B) st psi : + precond (eval_opcode sty env o st) psi <-> eval_precond_opcode env _ _ o psi st. + Proof. + destruct o; simpl; + try reflexivity; + try (destruct st; reflexivity); + try (destruct st as (x, (y, st)); reflexivity); + try (destruct st as (x, (y, st)); rewrite precond_bind; reflexivity); + try (destruct st as (x, (y, (z, SA))); reflexivity); + try (destruct st as ((x, y), st); reflexivity). + - destruct st as (x, ((tff, y), st)); reflexivity. + - destruct (stack_split st); reflexivity. + Qed. + + Lemma eval_seq_precond_correct_aux n + (eval_precond_correct : forall sty env tff0 A B (i : instruction sty tff0 A B) st psi, + precond (eval env i n st) psi <-> eval_precond n env i psi st) + {sty env tff0 A B} (i : instruction_seq sty tff0 A B) st psi : + precond (eval_seq env i n st) psi <-> eval_seq_precond n env i psi st. + Proof. + unfold eval_seq_precond in *. + induction i; simpl; fold data stack. + - reflexivity. + - apply eval_precond_correct. + - unfold eval_seq. + simpl. + rewrite precond_bind. + rewrite <- eval_precond_correct. + apply precond_eqv. + intro SB. + apply IHi. + Qed. + Lemma eval_precond_correct {sty env tff0 A B} (i : instruction sty tff0 A B) n st psi : precond (eval env i n st) psi <-> eval_precond n env i psi st. Proof. generalize sty env tff0 A B i st psi; clear sty env tff0 A B i st psi. induction n; intros sty env tff0 A B i st psi; [simpl; intuition|]. + specialize (@eval_seq_precond_correct_aux n IHn). + intro eval_seq_precond_correct. + unfold eval_seq_precond in *. + destruct i; simpl; fold data stack. - - reflexivity. + - apply eval_seq_precond_correct. - destruct st; reflexivity. - - rewrite precond_bind. - rewrite <- IHn. - apply precond_eqv. - intro SB. - apply IHn. - - destruct st as ([|], st); auto. - - destruct st as ([|], st). - + apply IHn. + - destruct st as (x, st); destruct (if_family_destruct _ x); apply eval_seq_precond_correct. + - destruct st as (x, st); destruct (loop_family_destruct _ x). + + rewrite precond_bind. + rewrite <- eval_seq_precond_correct. + apply precond_eqv. + intro st'. + apply IHn. + simpl. reflexivity. - - destruct st as ([|], st); simpl. - + apply (IHn _ _ _ _ _ (i;; LOOP_LEFT i)). - + reflexivity. - - destruct st as (x, ((tff, f), st)). - rewrite precond_bind. - rewrite <- (IHn _ _ _ _ _ f (x, tt) (fun '(y, tt) => psi (y, st))). - apply precond_eqv. - intros (y, []). - simpl. - reflexivity. - - destruct st as (x, ((tff, y), st)); reflexivity. - - destruct st; reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - reflexivity. - reflexivity. - reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st as (x, (y, st)); rewrite precond_bind; reflexivity. - - destruct st as (x, (y, st)); rewrite precond_bind; reflexivity. - - destruct st as (x, (y, st)); rewrite precond_bind; reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st as (x, (y, (z, st))); reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as ((x, y), st); reflexivity. - - destruct st as ((x, y), st); reflexivity. - - reflexivity. - - destruct st as (x, (y, st)); reflexivity. - - destruct st as (x, (y, (z, st))); reflexivity. - destruct st as (x, st). destruct (iter_destruct (iter_elt_type collection i) collection (iter_variant_field collection i) x) as [(hd, tl)|]. + rewrite precond_bind. - rewrite <- IHn. + rewrite <- eval_seq_precond_correct. apply precond_eqv. intro SA. apply IHn. + reflexivity. - - reflexivity. - - reflexivity. - - destruct st as (x, (y, st)); reflexivity. - destruct st as (x, st). destruct (map_destruct (map_in_type collection b i) b collection (map_out_collection_type collection b i) (map_variant_field collection b i) x) as [(hd, tl)|]. + rewrite precond_bind. - rewrite <- IHn. + rewrite <- eval_seq_precond_correct. apply precond_eqv. intros (bb, SA). rewrite precond_bind. @@ -1101,56 +1436,71 @@ Module Semantics(ST : SelfType)(C:ContractContext)(E:Env ST C). intros (c, B). reflexivity. + reflexivity. - - destruct st; reflexivity. - - reflexivity. - - destruct st as ([|], st); apply IHn. - - destruct st; reflexivity. - - destruct st; reflexivity. - - destruct st as ([|], st); apply IHn. - - destruct st as (x, (y, st)); reflexivity. - - reflexivity. - - destruct st as ([|], st); apply IHn. - - destruct st as (a, (b, (c, SA))). - destruct (create_contract env g p _ a b i c). - reflexivity. - destruct st as (a, (b, (c, SA))). - reflexivity. - - destruct st as (a, SA). - reflexivity. - - reflexivity. - - destruct st as (a, SA). - reflexivity. - - destruct st as (a, SA). - reflexivity. - - reflexivity. - - reflexivity. - - reflexivity. - - reflexivity. - - destruct st as (a, SA). + destruct (create_contract env g p an _ a b i c). reflexivity. - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (x, SA). - reflexivity. - - destruct st as (a, (b, (c, SA))). + - destruct st as (x, ((tff, f), st)). + rewrite precond_bind. + rewrite <- (eval_seq_precond_correct _ _ _ _ _ f (x, tt) (fun '(y, tt) => psi (y, st))). + apply precond_eqv. + intros (y, []). + simpl. reflexivity. - - reflexivity. - - reflexivity. - destruct (stack_split st). rewrite precond_bind. - apply IHn. - - destruct (stack_split st). - reflexivity. + apply eval_seq_precond_correct. + - apply eval_precond_opcode_correct. + Qed. + + Lemma eval_precond_eqv self_type env tff A B (i : instruction self_type tff A B) n st phi psi : + (forall st, phi st <-> psi st) -> + eval_precond n env i phi st <-> eval_precond n env i psi st. + Proof. + intro H. + do 2 rewrite <- eval_precond_correct. + apply precond_eqv. + assumption. + Qed. + + Lemma eval_seq_precond_correct {sty env tff0 A B} (i : instruction_seq sty tff0 A B) n st psi : + precond (eval_seq env i n st) psi <-> eval_seq_precond n env i psi st. + Proof. + apply eval_seq_precond_correct_aux. + intros; apply eval_precond_correct. + Qed. + + Lemma eval_seq_precond_eqv self_type env tff A B (i : instruction_seq self_type tff A B) n st phi psi : + (forall st, phi st <-> psi st) -> + eval_seq_precond n env i phi st <-> eval_seq_precond n env i psi st. + Proof. + intro H. + do 2 rewrite <- eval_seq_precond_correct. + apply precond_eqv. + assumption. + Qed. + + Lemma eval_seq_assoc_aux {sty env tffa tffb A B C} + (i1 : instruction_seq sty tffa A B) + (i2 : instruction_seq sty tffb B C) H n st psi : + eval_seq_precond n env (instruction_app_aux i1 H i2) psi st <-> + eval_seq_precond n env i1 (eval_seq_precond n env i2 psi) st. + Proof. + induction i1; unfold eval_seq_precond; simpl. - reflexivity. + - discriminate. + - apply eval_precond_eqv. + intro stB. + apply (IHi1 _ _ _ _). + Qed. + + Lemma eval_seq_assoc {sty env tff0 A B C} + (i1 : instruction_seq sty Datatypes.false A B) + (i2 : instruction_seq sty tff0 B C) n st psi : + eval_seq_precond n env (instruction_app i1 i2) psi st <-> + eval_seq_precond n env i1 (eval_seq_precond n env i2 psi) st. + Proof. + apply eval_seq_assoc_aux. Qed. End Semantics. diff --git a/src/michocoq/set.v b/src/michocoq/set.v index 01a25ad2e449b61d856bc8b67feee1fc5ad4c649..71436fcf8cfc06a484ce12cba633a186271ffc1b 100644 --- a/src/michocoq/set.v +++ b/src/michocoq/set.v @@ -23,7 +23,7 @@ (* Finite sets implemented by sorted lists *) Require Sorted Eqdep_dec. -Require Import error. +Require Import error decidable_types. Import error.Notations. Section definition. @@ -74,21 +74,7 @@ Section definition. Lemma decide_eq (a b : A) : {a = b} + {a <> b}. Proof. - case_eq (compare a b). - - intro H. - left. - apply compare_eq_iff. - assumption. - - intro H. - right. - intro ne. - rewrite <- compare_eq_iff in ne. - congruence. - - intro H. - right. - intro ne. - rewrite <- compare_eq_iff in ne. - congruence. + eapply decidable_types.comparable_decidable; eassumption. Qed. @@ -491,4 +477,15 @@ Section definition. apply sorted_irrel. Qed. + Lemma set_dec : decidable_types.decidable set. + Proof. + intros (l1, HS1) (l2, HS2). + case (decidable_types.list_dec decide_eq l1 l2). + - intro Hl; destruct Hl. + left. + f_equal. + apply sorted_irrel. + - intro Hr; right; congruence. + Qed. + End definition. diff --git a/src/michocoq/syntax.v b/src/michocoq/syntax.v index 63ae2fcace39607fcfa725cd1fc6a7fcc3070a19..59f75ff74ab2af790b862734c5ef162eb19bff2e 100644 --- a/src/michocoq/syntax.v +++ b/src/michocoq/syntax.v @@ -33,7 +33,8 @@ Require Export syntax_type. Section Overloading. -(* Boolean binary opertations (OR, XOR, AND) are overloaded as bitwise operations for nat. *) +(* Boolean binary opertations (OR and XOR) are overloaded as bitwise +operations for nat. AND also has a case for int and nat. *) Inductive bitwise_variant : type -> Set := | Bitwise_variant_bool : bitwise_variant bool | Bitwise_variant_nat : bitwise_variant nat. @@ -42,6 +43,16 @@ Structure bitwise_struct (a : type) := Canonical Structure bitwise_bool : bitwise_struct bool := {| bitwise_variant_field := Bitwise_variant_bool |}. Canonical Structure bitwise_nat : bitwise_struct nat := {| bitwise_variant_field := Bitwise_variant_nat |}. +Inductive and_variant : type -> type -> type -> Set := +| And_variant_bool : and_variant bool bool bool +| And_variant_nat : and_variant nat nat nat +| And_variant_int : and_variant int nat nat. +Structure and_struct (a b : type) := + Mk_and { and_ret_type : type; and_variant_field : and_variant a b and_ret_type }. +Canonical Structure and_bool : and_struct bool bool := {| and_variant_field := And_variant_bool |}. +Canonical Structure and_nat : and_struct nat nat := {| and_variant_field := And_variant_nat |}. +Canonical Structure and_int : and_struct int nat := {| and_variant_field := And_variant_int |}. + Set Warnings "-redundant-canonical-projection". (* Logical negation is also overloaded for int *) @@ -214,8 +225,10 @@ Canonical Structure mem_bigmap key val : mem_struct key (big_map key val) := (* UPDATE *) Inductive update_variant : comparable_type -> type -> type -> Set := | Update_variant_set a : update_variant a bool (set a) -| Update_variant_map key val : update_variant key (option val) (map key val) -| Update_variant_bigmap key val : update_variant key (option val) (big_map key val). +| Update_variant_map key val : + update_variant key (option val) (map key val) +| Update_variant_bigmap key val : + update_variant key (option val) (big_map key val). Structure update_struct key val collection := Mk_update { update_variant_field : update_variant key val collection }. Canonical Structure update_set a : update_struct a bool (set a) := @@ -228,16 +241,18 @@ Canonical Structure update_bigmap key val := (* ITER *) Inductive iter_variant : type -> type -> Set := | Iter_variant_set (a : comparable_type) : iter_variant a (set a) -| Iter_variant_map (key : comparable_type) val : iter_variant (pair key val) (map key val) +| Iter_variant_map (key : comparable_type) val : + iter_variant (pair key val) (map key val) | Iter_variant_list a : iter_variant a (list a). Structure iter_struct collection := Mk_iter { iter_elt_type : type; iter_variant_field : iter_variant iter_elt_type collection }. -Canonical Structure iter_set a : iter_struct (set a) := +Canonical Structure iter_set (a : comparable_type) : iter_struct (set a) := {| iter_variant_field := Iter_variant_set a |}. -Canonical Structure iter_map key val : iter_struct (map key val) := +Canonical Structure iter_map (key : comparable_type) val : + iter_struct (map key val) := {| iter_variant_field := Iter_variant_map key val |}. -Canonical Structure iter_list a : iter_struct (list a) := +Canonical Structure iter_list (a : type) : iter_struct (list a) := {| iter_variant_field := Iter_variant_list a |}. (* GET *) @@ -247,9 +262,9 @@ Inductive get_variant : comparable_type -> type -> type -> Set := Structure get_struct key collection := Mk_get { get_val_type : type; get_variant_field : get_variant key get_val_type collection }. -Canonical Structure get_map key val : get_struct key (map key val) := +Canonical Structure get_map key (val : type) : get_struct key (map key val) := {| get_variant_field := Get_variant_map key val |}. -Canonical Structure get_bigmap key val : get_struct key (big_map key val) := +Canonical Structure get_bigmap key (val : type) : get_struct key (big_map key val) := {| get_variant_field := Get_variant_bigmap key val |}. (* MAP *) @@ -262,9 +277,10 @@ Structure map_struct collection b := Mk_map { map_in_type : type; map_out_collection_type : type; map_variant_field : map_variant map_in_type b collection map_out_collection_type }. -Canonical Structure map_map key val b : map_struct (map key val) b := +Canonical Structure map_map (key : comparable_type) val b : + map_struct (map key val) b := {| map_variant_field := Map_variant_map key val b |}. -Canonical Structure map_list a b : map_struct (list a) b := +Canonical Structure map_list (a : type) b : map_struct (list a) b := {| map_variant_field := Map_variant_list a b |}. End Overloading. @@ -275,158 +291,211 @@ Inductive signature_constant : Set := Mk_sig : str -> signature_constant. Inductive key_constant : Set := Mk_key : str -> key_constant. Inductive key_hash_constant : Set := Mk_key_hash : str -> key_hash_constant. Inductive tez_constant : Set := Mk_tez : str -> tez_constant. -Inductive contract_constant : Set := Mk_contract : str -> contract_constant. -Inductive address_constant : Set := Mk_address : str -> address_constant. +Inductive smart_contract_address_constant : Set := +| Mk_smart_contract_address : str -> smart_contract_address_constant. +Inductive address_constant : Set := +| Implicit : key_hash_constant -> address_constant +| Originated : smart_contract_address_constant -> address_constant. Inductive operation_constant : Set := Mk_operation : str -> operation_constant. Inductive mutez_constant : Set := Mk_mutez : tez.mutez -> mutez_constant. Inductive chain_id_constant : Set := Mk_chain_id : str -> chain_id_constant. -Module Type ContractContext. - Parameter get_contract_type : contract_constant -> Datatypes.option type. -End ContractContext. - -Module Syntax(C : ContractContext). - Inductive elt_pair (a b : Set) : Set := | Elt : a -> b -> elt_pair a b. +Definition stack_type := Datatypes.list type. + +Definition get_entrypoint_root (e : annotation) (a : type) (an : annot_o) : + Datatypes.option type := + error.opt_bind an (fun e' => + match String.string_dec e e' with + | left _ => Some a + | right _ => None + end). + +Fixpoint get_entrypoint (e : annotation) (a : type) (an : annot_o) : Datatypes.option type := + error.opt_merge (get_entrypoint_root e a an) + (match a with + | or a annot_a b annot_b => + error.opt_merge + (get_entrypoint e a annot_a) + (get_entrypoint e b annot_b) + | _ => None + end). + +Definition get_entrypoint_opt (e : annot_o) (a : type) (an : annot_o) : + Datatypes.option type := + match e with + | None => + error.opt_merge + (get_entrypoint default_entrypoint.default a an) + (Some a) + | Some e => get_entrypoint e a an + end. + +Definition isSome {A : Set} (m : Datatypes.option A) : Prop := + match m with + | None => False + | Some _ => True + end. + +Definition isSome_maybe {A : Set} error (o : Datatypes.option A) : error.M (isSome o) := + match o return error.M (isSome o) with + | Some _ => error.Return I + | None => error.Failed _ error + end. + +Definition get_opt {A : Set} (m : Datatypes.option A) (H : isSome m) : A := + match m, H with + | Some a, I => a + | None, H => match H with end + end. + +Definition self_info := Datatypes.option (type * annot_o)%type. + +(* The self_type parameter is only here to ensure the so-called + uniform inheritance condition allowing to use Instruction_opcode as + an implicit coearcion *) + +Inductive opcode {self_type : self_info} : forall (A B : Datatypes.list type), Set := +| APPLY {a b c D} {_ : Bool.Is_true (is_packable a)} : + opcode (a ::: lambda (pair a b) c ::: D) (lambda b c ::: D) +| DUP {a A} : opcode (a ::: A) (a ::: a ::: A) +| SWAP {a b A} : opcode (a ::: b ::: A) (b ::: a ::: A) +| UNIT {A} : opcode A (unit :: A) +| EQ {S} : opcode (int ::: S) (bool ::: S) +| NEQ {S} : opcode (int ::: S) (bool ::: S) +| LT {S} : opcode (int ::: S) (bool ::: S) +| GT {S} : opcode (int ::: S) (bool ::: S) +| LE {S} : opcode (int ::: S) (bool ::: S) +| GE {S} : opcode (int ::: S) (bool ::: S) +| OR {b} {s : bitwise_struct b} {S} : opcode (b ::: b ::: S) (b ::: S) +| AND {a b} {s : and_struct a b} {S} : opcode (a ::: b ::: S) (and_ret_type _ _ s ::: S) +| XOR {b} {s : bitwise_struct b} {S} : opcode (b ::: b ::: S) (b ::: S) +| NOT {b} {s : not_struct b} {S} : opcode (b ::: S) (not_ret_type _ s ::: S) +| NEG {n} {s : neg_struct n} {S} : opcode (n ::: S) (int ::: S) +| ABS {S} : opcode (int ::: S) (nat ::: S) +| ISNAT {S} : opcode (int ::: S) (option nat ::: S) +| INT {S} : opcode (nat ::: S) (int ::: S) +| ADD {a b} {s : add_struct a b} {S} : + opcode (a ::: b ::: S) (add_ret_type _ _ s ::: S) +| SUB {a b} {s : sub_struct a b} {S} : + opcode (a ::: b ::: S) (sub_ret_type _ _ s ::: S) +| MUL {a b} {s : mul_struct a b} {S} : + opcode (a ::: b ::: S) (mul_ret_type _ _ s ::: S) +| EDIV {a b} {s : ediv_struct a b} {S} : opcode (a ::: b ::: S) (option (pair (ediv_quo_type _ _ s) (ediv_rem_type _ _ s)) :: S) +| LSL {S} : opcode (nat ::: nat ::: S) (nat ::: S) +| LSR {S} : opcode (nat ::: nat ::: S) (nat ::: S) +| COMPARE {a : comparable_type} {S} : opcode (a ::: a ::: S) (int ::: S) +| CONCAT {a} {i : stringlike_struct a} {S} : opcode (a ::: a ::: S) (a ::: S) +| CONCAT_list {a} {i : stringlike_struct a} {S} : opcode (list a ::: S) (a ::: S) +| SIZE {a} {i : size_struct a} {S} : + opcode (a ::: S) (nat ::: S) +| SLICE {a} {i : stringlike_struct a} {S} : + opcode (nat ::: nat ::: a ::: S) (option a ::: S) +| PAIR {a b S} : opcode (a ::: b ::: S) (pair a b :: S) +| CAR {a b S} : opcode (pair a b :: S) (a :: S) +| CDR {a b S} : opcode (pair a b :: S) (b :: S) +| EMPTY_SET elt {S} : opcode S (set elt ::: S) +| MEM {elt a} {i : mem_struct elt a} {S} : + opcode (elt ::: a ::: S) (bool ::: S) +| UPDATE {elt val collection} {i : update_struct elt val collection} {S} : + opcode (elt ::: val ::: collection ::: S) (collection ::: S) +| EMPTY_MAP (key : comparable_type) (val : type) {S} : + opcode S (map key val :: S) +| EMPTY_BIG_MAP (key : comparable_type) (val : type) {S} : + opcode S (big_map key val :: S) +| GET {key collection} {i : get_struct key collection} {S} : + opcode (key ::: collection ::: S) (option (get_val_type _ _ i) :: S) +| SOME {a S} : opcode (a :: S) (option a :: S) +| NONE (a : type) {S} : opcode S (option a :: S) +| LEFT {a} (b : type) {S} : opcode (a :: S) (or a None b None :: S) +| RIGHT (a : type) {b S} : opcode (b :: S) (or a None b None :: S) +| CONS {a S} : opcode (a ::: list a ::: S) (list a :: S) +| NIL (a : type) {S} : opcode S (list a :: S) +| TRANSFER_TOKENS {p S} : + opcode (p ::: mutez ::: contract p ::: S) (operation ::: S) +| SET_DELEGATE {S} : + opcode (option key_hash ::: S) (operation ::: S) +| BALANCE {S} : opcode S (mutez ::: S) +| ADDRESS {p S} : opcode (contract p ::: S) (address ::: S) +| CONTRACT {S} (annot_opt : Datatypes.option annotation) p : + opcode (address ::: S) (option (contract p) ::: S) +| SOURCE {S} : opcode S (address ::: S) +| SENDER {S} : opcode S (address ::: S) +| AMOUNT {S} : opcode S (mutez ::: S) +| IMPLICIT_ACCOUNT {S} : opcode (key_hash ::: S) (contract unit :: S) +| NOW {S} : opcode S (timestamp ::: S) +| PACK {a S} : opcode (a ::: S) (bytes ::: S) +| UNPACK a {S} : opcode (bytes ::: S) (option a ::: S) +| HASH_KEY {S} : opcode (key ::: S) (key_hash ::: S) +| BLAKE2B {S} : opcode (bytes ::: S) (bytes ::: S) +| SHA256 {S} : opcode (bytes ::: S) (bytes ::: S) +| SHA512 {S} : opcode (bytes ::: S) (bytes ::: S) +| CHECK_SIGNATURE {S} : opcode (key ::: signature ::: bytes ::: S) (bool ::: S) +| DIG (n : Datatypes.nat) {S1 S2 t} : + length S1 = n -> + opcode (S1 +++ (t ::: S2)) (t ::: S1 +++ S2) +| DUG (n : Datatypes.nat) {S1 S2 t} : + length S1 = n -> + opcode (t ::: S1 +++ S2) (S1 +++ (t ::: S2)) +| DROP (n : Datatypes.nat) {A B} : + length A = n -> + opcode (A +++ B) B +| CHAIN_ID {S} : opcode S (chain_id ::: S). + +Inductive if_family : forall (A B : Datatypes.list type) (a : type), Set := +| IF_bool : if_family nil nil bool +| IF_or a an b bn : if_family (a :: nil) (b :: nil) (or a an b bn) +| IF_option a : if_family nil (a :: nil) (option a) +| IF_list a : if_family (a ::: list a ::: nil) nil (list a). + +Inductive loop_family : forall (A B : Datatypes.list type) (a : type), Set := +| LOOP_bool : loop_family nil nil bool +| LOOP_or a an b bn : loop_family (a :: nil) (b :: nil) (or a an b bn). Inductive instruction : - forall (self_type : Datatypes.option type) (tail_fail_flag : Datatypes.bool) (A B : Datatypes.list type), Set := -| NOOP {self_type A} : instruction self_type Datatypes.false A A (* Undocumented *) + forall (self_type : self_info) (tail_fail_flag : Datatypes.bool) (A B : Datatypes.list type), Set := +| Instruction_seq {self_type tff A B} : + instruction_seq self_type tff A B -> + instruction self_type tff A B | FAILWITH {self_type A B a} : instruction self_type Datatypes.true (a ::: A) B -| SEQ {self_type A B C tff} : instruction self_type Datatypes.false A B -> instruction self_type tff B C -> instruction self_type tff A C -(* The instruction self_type SEQ I C is written "{self_type I ; C }" in Michelson *) -| IF_ {self_type A B tffa tffb} : - instruction self_type tffa A B -> instruction self_type tffb A B -> - instruction self_type (tffa && tffb) (bool ::: A) B -(* "IF" is a reserved keyword in file Coq.Init.Logic because it is -part of the notation "'IF' c1 'then' c2 'else' c3" so we cannot call -this constructor "IF" but we can make a notation for it. *) -| LOOP {self_type A} : instruction self_type Datatypes.false A (bool ::: A) -> instruction self_type Datatypes.false (bool ::: A) A -| LOOP_LEFT {self_type a b A} : instruction self_type Datatypes.false (a :: A) (or a b :: A) -> - instruction self_type Datatypes.false (or a b :: A) (b :: A) -| EXEC {self_type a b C} : instruction self_type Datatypes.false (a ::: lambda a b ::: C) (b :: C) -| APPLY {self_type a b c D} {_ : Bool.Is_true (is_packable a)} : - instruction self_type Datatypes.false (a ::: lambda (pair a b) c ::: D) (lambda b c ::: D) -| DUP {self_type a A} : instruction self_type Datatypes.false (a ::: A) (a ::: a ::: A) -| SWAP {self_type a b A} : instruction self_type Datatypes.false (a ::: b ::: A) (b ::: a ::: A) +| IF_ {self_type A B tffa tffb C1 C2 t} (i : if_family C1 C2 t) : + instruction_seq self_type tffa (C1 ++ A) B -> instruction_seq self_type tffb (C2 ++ A) B -> + instruction self_type (tffa && tffb) (t ::: A) B +| LOOP_ {self_type C1 C2 t A} (i : loop_family C1 C2 t) : + instruction_seq self_type Datatypes.false (C1 ++ A) (t :: A) -> + instruction self_type Datatypes.false (t :: A) (C2 ++ A) | PUSH (a : type) (x : concrete_data a) {self_type A} : instruction self_type Datatypes.false A (a :: A) -| UNIT {self_type A} : instruction self_type Datatypes.false A (unit :: A) | LAMBDA (a b : type) {self_type A tff} : - instruction None tff (a :: nil) (b :: nil) -> + instruction_seq None tff (a :: nil) (b :: nil) -> instruction self_type Datatypes.false A (lambda a b :: A) -| EQ {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| NEQ {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| LT {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| GT {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| LE {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| GE {self_type S} : instruction self_type Datatypes.false (int ::: S) (bool ::: S) -| OR {self_type b} {s : bitwise_struct b} {S} : instruction self_type Datatypes.false (b ::: b ::: S) (b ::: S) -| AND {self_type b} {s : bitwise_struct b} {S} : instruction self_type Datatypes.false (b ::: b ::: S) (b ::: S) -| XOR {self_type b} {s : bitwise_struct b} {S} : instruction self_type Datatypes.false (b ::: b ::: S) (b ::: S) -| NOT {self_type b} {s : not_struct b} {S} : instruction self_type Datatypes.false (b ::: S) (not_ret_type _ s ::: S) -| NEG {self_type n} {s : neg_struct n} {S} : instruction self_type Datatypes.false (n ::: S) (int ::: S) -| ABS {self_type S} : instruction self_type Datatypes.false (int ::: S) (nat ::: S) -| ISNAT {self_type S} : instruction self_type Datatypes.false (int ::: S) (option nat ::: S) -| INT {self_type S} : instruction self_type Datatypes.false (nat ::: S) (int ::: S) -| ADD {self_type a b} {s : add_struct a b} {S} : - instruction self_type Datatypes.false (a ::: b ::: S) (add_ret_type _ _ s ::: S) -| SUB {self_type a b} {s : sub_struct a b} {S} : - instruction self_type Datatypes.false (a ::: b ::: S) (sub_ret_type _ _ s ::: S) -| MUL {self_type a b} {s : mul_struct a b} {S} : - instruction self_type Datatypes.false (a ::: b ::: S) (mul_ret_type _ _ s ::: S) -| EDIV {self_type a b} {s : ediv_struct a b} {S} : instruction self_type Datatypes.false (a ::: b ::: S) (option (pair (ediv_quo_type _ _ s) (ediv_rem_type _ _ s)) :: S) -| LSL {self_type S} : instruction self_type Datatypes.false (nat ::: nat ::: S) (nat ::: S) -| LSR {self_type S} : instruction self_type Datatypes.false (nat ::: nat ::: S) (nat ::: S) -| COMPARE {self_type} {a : comparable_type} {S} : instruction self_type Datatypes.false (a ::: a ::: S) (int ::: S) -| CONCAT {self_type a} {i : stringlike_struct a} {S} : instruction self_type Datatypes.false (a ::: a ::: S) (a ::: S) -| CONCAT_list {self_type a} {i : stringlike_struct a} {S} : instruction self_type Datatypes.false (list a ::: S) (a ::: S) -| SIZE {self_type a} {i : size_struct a} {S} : - instruction self_type Datatypes.false (a ::: S) (nat ::: S) -| SLICE {self_type a} {i : stringlike_struct a} {S} : - instruction self_type Datatypes.false (nat ::: nat ::: a ::: S) (option a ::: S) -| PAIR {self_type a b S} : instruction self_type Datatypes.false (a ::: b ::: S) (pair a b :: S) -| CAR {self_type a b S} : instruction self_type Datatypes.false (pair a b :: S) (a :: S) -| CDR {self_type a b S} : instruction self_type Datatypes.false (pair a b :: S) (b :: S) -| EMPTY_SET elt {self_type S} : instruction self_type Datatypes.false S (set elt ::: S) -| MEM {self_type elt a} {i : mem_struct elt a} {S} : - instruction self_type Datatypes.false (elt ::: a ::: S) (bool ::: S) -| UPDATE {self_type elt val collection} {i : update_struct elt val collection} {S} : - instruction self_type Datatypes.false (elt ::: val ::: collection ::: S) (collection ::: S) | ITER {self_type collection} {i : iter_struct collection} {A} : - instruction self_type Datatypes.false (iter_elt_type _ i ::: A) A -> instruction self_type Datatypes.false (collection :: A) A -| EMPTY_MAP (key : comparable_type) (val : type) {self_type S} : - instruction self_type Datatypes.false S (map key val :: S) -| EMPTY_BIG_MAP (key : comparable_type) (val : type) {self_type S} : - instruction self_type Datatypes.false S (big_map key val :: S) -| GET {self_type key collection} {i : get_struct key collection} {S} : - instruction self_type Datatypes.false (key ::: collection ::: S) (option (get_val_type _ _ i) :: S) + instruction_seq self_type Datatypes.false (iter_elt_type _ i ::: A) A -> instruction self_type Datatypes.false (collection :: A) A | MAP {self_type collection b} {i : map_struct collection b} {A} : - instruction self_type Datatypes.false (map_in_type _ _ i :: A) (b :: A) -> + instruction_seq self_type Datatypes.false (map_in_type _ _ i :: A) (b :: A) -> instruction self_type Datatypes.false (collection :: A) (map_out_collection_type _ _ i :: A) -| SOME {self_type a S} : instruction self_type Datatypes.false (a :: S) (option a :: S) -| NONE (a : type) {self_type S} : instruction self_type Datatypes.false S (option a :: S) -(* Not the one documented, see https://gitlab.com/tezos/tezos/issues/471 *) -| IF_NONE {self_type a A B tffa tffb} : - instruction self_type tffa A B -> instruction self_type tffb (a :: A) B -> - instruction self_type (tffa && tffb) (option a :: A) B -| LEFT {self_type a} (b : type) {S} : instruction self_type Datatypes.false (a :: S) (or a b :: S) -| RIGHT (a : type) {self_type b S} : instruction self_type Datatypes.false (b :: S) (or a b :: S) -| IF_LEFT {self_type a b A B tffa tffb} : - instruction self_type tffa (a :: A) B -> - instruction self_type tffb (b :: A) B -> - instruction self_type (tffa && tffb) (or a b :: A) B -| CONS {self_type a S} : instruction self_type Datatypes.false (a ::: list a ::: S) (list a :: S) -| NIL (a : type) {self_type S} : instruction self_type Datatypes.false S (list a :: S) -| IF_CONS {self_type a A B tffa tffb} : - instruction self_type tffa (a ::: list a ::: A) B -> - instruction self_type tffb A B -> - instruction self_type (tffa && tffb) (list a :: A) B -| CREATE_CONTRACT {self_type S tff} (g p : type) : - instruction (Some p) tff (pair p g :: nil) (pair (list operation) g :: nil) -> +| CREATE_CONTRACT {self_type S tff} (g p : type) (an : annot_o) : + instruction_seq (Some (p, an)) tff (pair p g :: nil) (pair (list operation) g :: nil) -> instruction self_type Datatypes.false (option key_hash ::: mutez ::: g ::: S) (operation ::: address ::: S) -| TRANSFER_TOKENS {self_type p S} : - instruction self_type Datatypes.false (p ::: mutez ::: contract p ::: S) (operation ::: S) -| SET_DELEGATE {self_type S} : - instruction self_type Datatypes.false (option key_hash ::: S) (operation ::: S) -| BALANCE {self_type S} : instruction self_type Datatypes.false S (mutez ::: S) -| ADDRESS {self_type p S} : instruction self_type Datatypes.false (contract p ::: S) (address ::: S) -| CONTRACT {self_type S} p : instruction self_type Datatypes.false (address ::: S) (option (contract p) ::: S) -(* Mistake in the doc: the return type must be an option *) -| SOURCE {self_type S} : instruction self_type Datatypes.false S (address ::: S) -| SENDER {self_type S} : instruction self_type Datatypes.false S (address ::: S) -| SELF {self_type S} : instruction (Some self_type) Datatypes.false S (contract self_type :: S) -(* p should be the current parameter type *) -| AMOUNT {self_type S} : instruction self_type Datatypes.false S (mutez ::: S) -| IMPLICIT_ACCOUNT {self_type S} : instruction self_type Datatypes.false (key_hash ::: S) (contract unit :: S) -| NOW {self_type S} : instruction self_type Datatypes.false S (timestamp ::: S) -| PACK {self_type a S} : instruction self_type Datatypes.false (a ::: S) (bytes ::: S) -| UNPACK a {self_type S} : instruction self_type Datatypes.false (bytes ::: S) (option a ::: S) -| HASH_KEY {self_type S} : instruction self_type Datatypes.false (key ::: S) (key_hash ::: S) -| BLAKE2B {self_type S} : instruction self_type Datatypes.false (bytes ::: S) (bytes ::: S) -| SHA256 {self_type S} : instruction self_type Datatypes.false (bytes ::: S) (bytes ::: S) -| SHA512 {self_type S} : instruction self_type Datatypes.false (bytes ::: S) (bytes ::: S) -| CHECK_SIGNATURE {self_type S} : instruction self_type Datatypes.false (key ::: signature ::: bytes ::: S) (bool ::: S) -| DIG (n : Datatypes.nat) {self_type S1 S2 t} : - length S1 = n -> - instruction self_type Datatypes.false (S1 +++ (t ::: S2)) (t ::: S1 +++ S2) -| DUG (n : Datatypes.nat) {self_type S1 S2 t} : - length S1 = n -> - instruction self_type Datatypes.false (t ::: S1 +++ S2) (S1 +++ (t ::: S2)) +| SELF {self_type self_annot S} (annot_opt : annot_o) (H : isSome (get_entrypoint_opt annot_opt self_type self_annot)) : + instruction (Some (self_type, self_annot)) Datatypes.false S (contract (get_opt _ H) :: S) +| EXEC {self_type a b C} : instruction self_type Datatypes.false + (a ::: lambda a b ::: C) (b :: C) | DIP (n : Datatypes.nat) {self_type A B C} : length A = n -> - instruction self_type Datatypes.false B C -> + instruction_seq self_type Datatypes.false B C -> instruction self_type Datatypes.false (A +++ B) (A +++ C) -| DROP (n : Datatypes.nat) {self_type A B} : - length A = n -> - instruction self_type Datatypes.false (A +++ B) B -| CHAIN_ID {self_type S} : instruction self_type Datatypes.false S (chain_id ::: S) - -with -concrete_data : type -> Set := +| Instruction_opcode {self_type A B} : opcode (self_type := self_type) A B -> instruction self_type Datatypes.false A B +with instruction_seq : + forall (self_type : self_info) (tail_fail_flag : Datatypes.bool) (A B : Datatypes.list type), Set := +| NOOP {self_type A} : instruction_seq self_type Datatypes.false A A +| Tail_fail {self_type A B} : instruction self_type Datatypes.true A B -> instruction_seq self_type Datatypes.true A B +(* The instruction self_type SEQ I C is written "{ I ; C }" in Michelson *) +| SEQ {self_type A B C tff} : instruction self_type Datatypes.false A B -> instruction_seq self_type tff B C -> instruction_seq self_type tff A C +with concrete_data : type -> Set := | Int_constant : Z -> concrete_data int | Nat_constant : N -> concrete_data nat | String_constant : String.string -> concrete_data string @@ -437,14 +506,12 @@ concrete_data : type -> Set := | Key_hash_constant : String.string -> concrete_data key_hash | Mutez_constant : mutez_constant -> concrete_data mutez | Address_constant : address_constant -> concrete_data address -| Contract_constant {a} : forall cst : contract_constant, - C.get_contract_type cst = Some a -> concrete_data (contract a) | Unit : concrete_data unit | True_ : concrete_data bool | False_ : concrete_data bool | Pair {a b : type} : concrete_data a -> concrete_data b -> concrete_data (pair a b) -| Left {a b : type} : concrete_data a -> concrete_data (or a b) -| Right {a b : type} : concrete_data b -> concrete_data (or a b) +| Left {a b : type} (x : concrete_data a) an bn : concrete_data (or a an b bn) +| Right {a b : type} (x : concrete_data b) an bn : concrete_data (or a an b bn) | Some_ {a : type} : concrete_data a -> concrete_data (option a) | None_ {a : type} : concrete_data (option a) | Concrete_list {a} : Datatypes.list (concrete_data a) -> concrete_data (list a) @@ -453,17 +520,149 @@ concrete_data : type -> Set := | Concrete_map {a : comparable_type} {b} : Datatypes.list (elt_pair (concrete_data a) (concrete_data b)) -> concrete_data (map a b) -| Instruction {a b} tff : instruction None tff (a ::: nil) (b ::: nil) -> +| Concrete_big_map {a : comparable_type} {b} : + Datatypes.list (elt_pair (concrete_data a) (concrete_data b)) -> + concrete_data (big_map a b) +| Instruction {a b} tff : instruction_seq None tff (a ::: nil) (b ::: nil) -> concrete_data (lambda a b) | Chain_id_constant : chain_id_constant -> concrete_data chain_id. -(* TODO: add the no-ops CAST and RENAME *) + +Coercion Instruction_opcode : opcode >-> instruction. + +Fixpoint tail_fail_induction self_type A B + (i : instruction self_type true A B) + (P : forall self_type A B, instruction self_type true A B -> Type) + (Q : forall self_type A B, instruction_seq self_type true A B -> Type) + (HFAILWITH : forall st a A B, P st (a ::: A) B FAILWITH) + (HIF : forall st A B C1 C2 t (f : if_family C1 C2 t) i1 i2, + Q st (C1 ++ A)%list B i1 -> + Q st (C2 ++ A)%list B i2 -> + P st (t ::: A) B (IF_ f i1 i2)) + (HSEQ : forall st A B C i1 i2, + Q st B C i2 -> Q st A C (SEQ i1 i2)) + (HTF : forall st A B i, P st A B i -> Q st A B (Tail_fail i)) + (HIS : forall st A B i, Q st A B i -> P st A B (Instruction_seq i)) + : P self_type A B i := + let P' st b A B : instruction st b A B -> Type := + if b return instruction st b A B -> Type + then P st A B + else fun i => True + in + match i as i0 in instruction st b A B return P' st b A B i0 + with + | FAILWITH => HFAILWITH _ _ _ _ + | @IF_ _ A B tffa tffb _ _ _ f i1 i2 => + (if tffa as tffa return + forall i1, P' _ (tffa && tffb)%bool _ _ (IF_ f i1 i2) + then + fun i1 => + (if tffb return + forall i2, + P' _ tffb _ _ (IF_ f i1 i2) + then + fun i2 => + HIF _ _ _ _ _ _ f i1 i2 + (tail_fail_induction_seq _ _ _ i1 P Q HFAILWITH HIF HSEQ HTF HIS) + (tail_fail_induction_seq _ _ _ i2 P Q HFAILWITH HIF HSEQ HTF HIS) + else + fun _ => I) i2 + else + fun _ => I) i1 + | @Instruction_seq _ true _ _ i => + HIS _ _ _ _ (tail_fail_induction_seq _ _ _ i P Q HFAILWITH HIF HSEQ HTF HIS) + | _ => I + end +with tail_fail_induction_seq self_type A B + (i : instruction_seq self_type true A B) + (P : forall self_type A B, instruction self_type true A B -> Type) + (Q : forall self_type A B, instruction_seq self_type true A B -> Type) + (HFAILWITH : forall st a A B, P st (a ::: A) B FAILWITH) + (HIF : forall st A B C1 C2 t (f : if_family C1 C2 t) i1 i2, + Q st (C1 ++ A)%list B i1 -> + Q st (C2 ++ A)%list B i2 -> + P st (t ::: A) B (IF_ f i1 i2)) + (HSEQ : forall st A B C i1 i2, + Q st B C i2 -> Q st A C (SEQ i1 i2)) + (HTF : forall st A B i, P st A B i -> Q st A B (Tail_fail i)) + (HIS : forall st A B i, Q st A B i -> P st A B (Instruction_seq i)) + : Q self_type A B i := + let Q' st b A B : instruction_seq st b A B -> Type := + if b return instruction_seq st b A B -> Type + then Q st A B + else fun i => True + in + match i as i0 in instruction_seq st b A B return Q' st b A B i0 + with + | @SEQ _ A B C tff i1 i2 => + (if tff return + forall i2 : instruction_seq _ tff B C, + Q' _ tff A C (SEQ i1 i2) + then + fun i2 => + HSEQ _ _ _ _ i1 i2 + (tail_fail_induction_seq _ B C i2 P Q HFAILWITH HIF HSEQ HTF HIS) + else fun i2 => I) + i2 + | @Tail_fail _ A B i => HTF _ _ _ i (tail_fail_induction _ A B i P Q HFAILWITH HIF HSEQ HTF HIS) + | _ => I + end . + +Corollary tail_fail_induction_and_seq + (P : forall self_type A B, instruction self_type true A B -> Type) + (Q : forall self_type A B, instruction_seq self_type true A B -> Type) + (HFAILWITH : forall st a A B, P st (a ::: A) B FAILWITH) + (HIF : forall st A B C1 C2 t (f : if_family C1 C2 t) i1 i2, + Q st (C1 ++ A)%list B i1 -> + Q st (C2 ++ A)%list B i2 -> + P st (t ::: A) B (IF_ f i1 i2)) + (HSEQ : forall st A B C i1 i2, + Q st B C i2 -> Q st A C (SEQ i1 i2)) + (HTF : forall st A B i, P st A B i -> Q st A B (Tail_fail i)) + (HIS : forall st A B i, Q st A B i -> P st A B (Instruction_seq i)) + : (forall self_type A B i, P self_type A B i) * + (forall self_type A B i, Q self_type A B i). +Proof. + split. + - intros; eapply tail_fail_induction; eassumption. + - intros; eapply tail_fail_induction_seq; eassumption. +Defined. + +Definition tail_fail_change_range {self_type} A B B' (i : instruction self_type true A B) : + instruction self_type true A B'. +Proof. + apply (tail_fail_induction self_type A B i (fun self_type A B i => instruction self_type true A B') + (fun self_type A B i => instruction_seq self_type true A B')); clear A B i. + - intros st a A _. + apply FAILWITH. + - intros st A B C1 C2 t f _ _ i1 i2. + apply (IF_ f i1 i2). + - intros st A B C i1 _ i2. + apply (SEQ i1 i2). + - intros st A B _ i. + apply (Tail_fail i). + - intros st A B _ i. + apply (Instruction_seq i). +Defined. + +Definition seq_aux {self_type A B C tffa tffb} : + instruction self_type tffa A B -> + instruction_seq self_type tffb B C -> + instruction_seq self_type (tffa || tffb)%bool A C := + if tffa + return + (instruction self_type tffa A B -> + instruction_seq self_type tffb B C -> + instruction_seq self_type (tffa || tffb) A C) + then + fun i _ => Tail_fail (tail_fail_change_range A B C i) + else SEQ. Coercion int_constant := Int_constant. Coercion nat_constant := Nat_constant. Coercion string_constant := String_constant. -Definition full_contract tff param storage := - instruction (Some param) tff +Definition full_contract tff param annot storage := + instruction_seq (Some (param, annot)) tff ((pair param storage) ::: nil) ((pair (list operation) storage) ::: nil). @@ -471,24 +670,64 @@ Record contract_file : Set := Mk_contract_file { contract_file_parameter : type; + contract_file_annotation : annot_o; contract_file_storage : type; contract_tff : Datatypes.bool; contract_file_code : full_contract contract_tff contract_file_parameter + contract_file_annotation contract_file_storage; }. -Notation "'IF'" := (IF_). -Definition stack_type := Datatypes.list type. +Notation "'IF'" := (IF_ IF_bool) : michelson_scope. +Notation "'IF_TRUE'" := (IF_ IF_bool) : michelson_scope. +Notation "'IF_LEFT'" := (IF_ (IF_or _ _ _ _)) : michelson_scope. +Notation "'IF_NONE'" := (IF_ (IF_option _)) : michelson_scope. +Notation "'IF_CONS'" := (IF_ (IF_list _)) : michelson_scope. +Notation "'LOOP'" := (LOOP_ LOOP_bool) : michelson_scope. +Notation "'LOOP_LEFT'" := (LOOP_ (LOOP_or _ _)) : michelson_scope. + +Delimit Scope michelson_scope with michelson. +Bind Scope michelson_scope with instruction. +Bind Scope michelson_scope with instruction_seq. +Bind Scope michelson_scope with full_contract. + +Definition instruction_wrap {A B : stack_type} {self_type tff} + : instruction self_type tff A B -> + instruction_seq self_type tff A B := + if tff return instruction self_type tff A B -> instruction_seq self_type tff A B then + Tail_fail + else fun i => SEQ i NOOP. + +Fixpoint instruction_app_aux + {A B C : stack_type} {self_type tff1 tff2} + (i1 : instruction_seq self_type tff1 A B) : + tff1 = false -> instruction_seq self_type tff2 B C -> instruction_seq self_type tff2 A C := + match i1 with + | NOOP => fun _ i2 => i2 + | SEQ i11 i12 => + fun H i2 => SEQ i11 (instruction_app_aux i12 H i2) + | Tail_fail i => + fun H => False_rec _ (Bool.diff_true_false H) + end. + +Definition instruction_app {A B C : stack_type} {self_type tff} + (i1 : instruction_seq self_type false A B) + (i2 : instruction_seq self_type tff B C) : + instruction_seq self_type tff A C := + instruction_app_aux i1 eq_refl i2. + +Notation "A ;;; B" := (instruction_app A B) (at level 100, right associativity). -Notation "A ;; B" := (SEQ A B) (at level 100, right associativity). +Notation "A ;; B" := (seq_aux A B) (at level 100, right associativity). -(* For debugging purpose, a version of ;; with explicit stack type *) -Notation "A ;;; S ;;;; B" := (@SEQ _ _ S _ A B) (at level 100, only parsing). +Notation "{ }" := NOOP : michelson_scope. -Notation "n ~Mutez" := (exist _ (int64bv.of_Z n) eq_refl) (at level 100). +Notation "{ A ; .. ; B }" := (seq_aux A .. (seq_aux B NOOP) ..) : michelson_scope. + +Notation "n ~Mutez" := (exist _ (int64bv.of_Z_safe n eq_refl) I) (at level 100). Notation "n ~mutez" := (Mutez_constant (Mk_mutez (n ~Mutez))) (at level 100). @@ -644,4 +883,27 @@ Proof. rewrite <- Hpi. rewrite IHl1. reflexivity. Qed. -End Syntax. +Fixpoint typed_concrete_stack l := + match l with + | nil => Datatypes.unit + | cons ty l => (syntax.concrete_data ty * typed_concrete_stack l)%type + end. + +Record tzt_file : Set := + Mk_tzt_file + { + tzt_file_input_type : Datatypes.list type; + tzt_file_output_type : Datatypes.list type; + tzt_file_input : typed_concrete_stack tzt_file_input_type; + tzt_file_output : typed_concrete_stack tzt_file_output_type; + tzt_file_code : + instruction_seq None Datatypes.false tzt_file_input_type tzt_file_output_type; + tzt_file_amount : Datatypes.option (concrete_data mutez); + tzt_file_balance : Datatypes.option (concrete_data mutez); + tzt_file_chain_id : Datatypes.option (concrete_data chain_id); + tzt_file_now : Datatypes.option (concrete_data timestamp); + tzt_file_sender : Datatypes.option (concrete_data address); + tzt_file_source : Datatypes.option (concrete_data address); + tzt_file_param : Datatypes.option type; + tzt_file_self : Datatypes.option (concrete_data address); + }. diff --git a/src/michocoq/syntax_type.v b/src/michocoq/syntax_type.v index b2e73e8ae4c14b8dedbd624a119c2d2b186b9b92..4ea512528dd0dd97a6bc92195e55c0d5413bbefb 100644 --- a/src/michocoq/syntax_type.v +++ b/src/michocoq/syntax_type.v @@ -1,3 +1,15 @@ +Require String. + +Definition annotation := String.string. +Definition annot_o := Datatypes.option annotation. + +Module default_entrypoint. + Import String. + + Definition default : annotation := "%default"%string. + +End default_entrypoint. + Inductive simple_comparable_type : Set := | string | nat @@ -19,21 +31,21 @@ Proof. Defined. Inductive type : Set := -| Comparable_type : simple_comparable_type -> type -| key : type -| unit : type -| signature : type -| option : type -> type -| list : type -> type -| set : comparable_type -> type -| contract : type -> type -| operation : type -| pair : type -> type -> type -| or : type -> type -> type -| lambda : type -> type -> type -| map : comparable_type -> type -> type -| big_map : comparable_type -> type -> type -| chain_id : type. +| Comparable_type (_ : simple_comparable_type) +| key +| unit +| signature +| option (a : type) +| list (a : type) +| set (a : comparable_type) +| contract (a : type) +| operation +| pair (a : type) (b : type) +| or (a : type) (_ : annot_o) (b : type) (_ : annot_o) +| lambda (a b : type) +| map (k : comparable_type) (v : type) +| big_map (k : comparable_type) (v : type) +| chain_id. Fixpoint comparable_type_to_type (c : comparable_type) : type := match c with @@ -53,7 +65,7 @@ Fixpoint is_packable (a : type) : Datatypes.bool := | option ty | list ty | map _ ty => is_packable ty - | pair a b | or a b => is_packable a && is_packable b + | pair a b | or a _ b _ => is_packable a && is_packable b end. Lemma type_dec (a b : type) : {a = b} + {a <> b}. diff --git a/src/michocoq/tez.v b/src/michocoq/tez.v index 9951321ae7b640ef7dd8cbdcf8b83964fce09fa8..ee48b905859bcb89ef83fd316090b99fbe687833 100644 --- a/src/michocoq/tez.v +++ b/src/michocoq/tez.v @@ -26,8 +26,9 @@ Require Import ZArith. Require int64bv. Require Eqdep_dec. Require error. +Import error.Notations. -Definition mutez : Set := {t : int64bv.int64 | int64bv.sign t = false }. +Definition mutez : Set := {t : int64bv.int64 | Bool.Is_true (negb (int64bv.sign t)) }. Definition to_int64 (t : mutez) : int64bv.int64 := let (t, _) := t in t. @@ -41,50 +42,63 @@ Proof. simpl in H. destruct H. f_equal. - apply Eqdep_dec.eq_proofs_unicity. - intros. - destruct (Bool.bool_dec x y); tauto. + apply error.Is_true_UIP. Qed. -Coercion to_int64 : mutez >-> int64bv.int64. - -Definition to_Z (t : mutez) : Z := int64bv.to_Z t. - -Definition of_int64_aux (t : int64bv.int64) (sign : bool) : - int64bv.sign t = sign -> error.M mutez := - if sign return int64bv.sign t = sign -> error.M mutez - then fun _ => error.Failed _ error.Overflow - else fun H => error.Return (exist _ t H). +Definition to_Z (t : mutez) : Z := int64bv.to_Z (to_int64 t). Definition of_int64 (t : int64bv.int64) : error.M mutez := - of_int64_aux t (int64bv.sign t) eq_refl. - -Lemma of_int64_return (t : int64bv.int64) (H : int64bv.sign t = false) : - of_int64 t = error.Return (exist _ t H). + let! H := + error.dif + (A := fun b => error.M (Bool.Is_true (negb b))) + (int64bv.sign t) + (fun _ => error.Failed _ error.Overflow) + (fun H => error.Return H) + in + @error.Return mutez (exist _ t H). + +Lemma of_int64_to_int64_eqv (t : int64bv.int64) (m : mutez) : + to_int64 m = t <-> of_int64 t = error.Return m. Proof. - unfold of_int64. - cut (forall b H', of_int64_aux t b H' = error.Return (exist _ t H)). - - intro Hl. - apply Hl. - - intros b H'. - unfold of_int64_aux. - destruct b. - + congruence. - + f_equal. - apply to_int64_inj. - reflexivity. + unfold of_int64, to_int64. + destruct m as (t', H). + rewrite error.bind_eq_return. + split. + - intro; subst. + exists H. + split; [| reflexivity]. + apply (@error.dif_case (fun b => error.M (Bool.Is_true (negb b)))). + + intro Hn; destruct (int64bv.sign t); contradiction. + + intro H'; f_equal; apply error.Is_true_UIP. + - intros (H', (Hd, HR)). + congruence. Qed. Definition of_Z (t : Z) : error.M mutez := - of_int64 (int64bv.of_Z t). + let! b := int64bv.of_Z t in + of_int64 b. -Lemma of_Z_to_Z (t : mutez) : of_Z (to_Z t) = error.Return t. +Lemma of_Z_to_Z_eqv (z : Z) (t : mutez) : to_Z t = z <-> of_Z z = error.Return t. Proof. unfold of_Z, to_Z. - rewrite int64bv.of_Z_to_Z. - destruct t. - simpl. - apply of_int64_return. + split. + - intro; subst z. + rewrite int64bv.of_Z_to_Z. + simpl. + apply of_int64_to_int64_eqv. + reflexivity. + - intro H. + apply (error.bind_eq_return of_int64) in H. + destruct H as (b, (Hz, Hb)). + apply of_int64_to_int64_eqv in Hb. + rewrite <- int64bv.of_Z_to_Z_eqv in Hz. + congruence. +Qed. + +Lemma of_Z_to_Z (t : mutez) : of_Z (to_Z t) = error.Return t. +Proof. + rewrite <- of_Z_to_Z_eqv. + reflexivity. Qed. Definition compare (t1 t2 : mutez) : comparison := diff --git a/src/michocoq/typed_optimizer.v b/src/michocoq/typed_optimizer.v new file mode 100644 index 0000000000000000000000000000000000000000..620e16643149059e115e53aa9d8222bff8f21fca --- /dev/null +++ b/src/michocoq/typed_optimizer.v @@ -0,0 +1,1674 @@ +(* Open Source License *) +(* Copyright (c) 2019 Nomadic Labs. *) + +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"), *) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) + +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) + +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) + +(* Same as the untyped optimizer but at the level of Michocoq.syntax *) + +From Michocoq Require untyped_syntax typer untyper semantics. +From Michocoq Require Import syntax. +Import error.Notations. +Import Notations. +Require optimizer. +Require Import ZArith. +Require JMeq. +Require Import String. + +Definition hide_tf {st A B} (i : instruction st true A B) : + sigT (fun tff => instruction st tff A B) := + existT _ true i. + +Definition hide_ntf {st A B} (i : instruction st false A B) : + sigT (fun tff => instruction st tff A B) := + existT _ false i. + + + +(* Manipulations of options *) + +Definition opt_get {A} (o : Datatypes.option A) (default : A) : A := + match o with Some x => x | None => default end. + +Lemma unsome {A} (x y : A) : Some x = Some y -> x = y. +Proof. + congruence. +Qed. + +Lemma bind_some {A B : Set} (y : Datatypes.option A) (w : B) z : (let? x := y in z x) = Some w <-> (exists x, y = Some x /\ z x = Some w). +Proof. + destruct y; simpl; split. + - intro H; exists a; split; congruence. + - intros (x, (Hx, Hz)); congruence. + - discriminate. + - intros (x, (Hx, Hz)); discriminate. +Qed. + +Fixpoint visit_instruction + (F : forall st tff A B, + instruction_seq st tff A B -> instruction_seq st tff A B) + {st tff A B} + (i : instruction st tff A B) {struct i} : instruction st tff A B := + match i with + | Instruction_seq i => Instruction_seq (visit_instruction_seq F i) + | DIP n H i => DIP n H (visit_instruction_seq F i) + | IF_ f i1 i2 => + IF_ f (visit_instruction_seq F i1) (visit_instruction_seq F i2) + | LOOP_ f i => + LOOP_ f (visit_instruction_seq F i) + | ITER i => ITER (visit_instruction_seq F i) + | MAP i => MAP (visit_instruction_seq F i) + + (* Note that LAMBDA a b i => LAMBDA a b (visit_instruction_seq F i) + would be incorrect because we can use PACK to distinguish + semantically equivalent lambdas in Michelson *) + | LAMBDA a b i => LAMBDA a b i + | CREATE_CONTRACT a b an i => CREATE_CONTRACT a b an i + | PUSH ty x => PUSH ty x + | FAILWITH => FAILWITH + | SELF an H => SELF an H + | EXEC => EXEC + | Instruction_opcode op => Instruction_opcode op + end +with +visit_instruction_seq f {st tff A B} (i : instruction_seq st tff A B) {struct i} +: instruction_seq st tff A B := + match i with + | NOOP => f _ _ _ _ NOOP + | Tail_fail i => + let i' := visit_instruction f i in + f _ _ _ _ (Tail_fail i') + | SEQ i1 i2 => + let i1' := visit_instruction f i1 in + let i2' := visit_instruction_seq f i2 in + f _ _ _ _ (SEQ i1' i2') + end. + +Definition untype_fun_seq + (F1 : forall st tff A B, instruction_seq st tff A B -> + instruction_seq st tff A B) + (F2 : untyped_syntax.instruction_seq -> untyped_syntax.instruction_seq) := + forall st tff A B i, + untyper.untype_instruction_seq untyper.untype_Optimized (F1 st tff A B i) = F2 (untyper.untype_instruction_seq untyper.untype_Optimized i). + +Fixpoint untype_visit_instruction F1 F2 + (H : untype_fun_seq F1 F2) + (HNOOP : F2 untyped_syntax.NOOP = untyped_syntax.NOOP) + st tff A B + (i : instruction st tff A B) : + untyper.untype_instruction untyper.untype_Optimized (visit_instruction F1 i) = + optimizer.visit_instruction F2 (untyper.untype_instruction untyper.untype_Optimized i) +with +untype_visit_instruction_seq F1 F2 + (H : untype_fun_seq F1 F2) + (HNOOP : F2 untyped_syntax.NOOP = untyped_syntax.NOOP) + st tff A B + (i : instruction_seq st tff A B) : + untyper.untype_instruction_seq untyper.untype_Optimized (visit_instruction_seq F1 i) = + optimizer.visit_instruction_seq F2 (untyper.untype_instruction_seq untyper.untype_Optimized i). +Proof. + - destruct i; simpl; try reflexivity; try (repeat f_equal; apply untype_visit_instruction_seq; assumption). + - destruct i. + + apply H. + + simpl. + rewrite H. + simpl. + repeat f_equal. + * apply (untype_visit_instruction F1 F2); assumption. + * symmetry; assumption. + + simpl. + rewrite H. + simpl. + repeat f_equal. + * apply (untype_visit_instruction F1 F2); assumption. + * apply (untype_visit_instruction_seq F1 F2); assumption. +Qed. + +Lemma stype_refl (A : Datatypes.list type) (H : A = A) : H = eq_refl. +Proof. + apply Eqdep_dec.UIP_dec. + apply stype_dec. +Qed. + +Lemma st_dec (st1 st2 : self_info) : sumbool (st1 = st2) (st1 <> st2). +Proof. + repeat decide equality. +Qed. + +Lemma st_refl (st : self_info) (H : st = st) : H = eq_refl. +Proof. + apply Eqdep_dec.UIP_dec. + apply st_dec. +Qed. + +Definition cast_instruction_seq_opt {st tff A B st' tff' A' B'} + (i : instruction_seq st tff A B) + : Datatypes.option (instruction_seq st' tff' A' B'). +Proof. + case (st_dec st st'); [| intros; exact None]. + case (error.bool_dec tff tff'); [| intros; exact None]. + case (stype_dec A A'); [| intros; exact None]. + case (stype_dec B B'); [| intros; exact None]. + intros; subst; exact (Some i). +Defined. + +Lemma cast_instruction_seq_same {st tff A B} (i : instruction_seq st tff A B) : + cast_instruction_seq_opt i = Some i. +Proof. + unfold cast_instruction_seq_opt. + destruct (st_dec st st) as [Hst | n]; [|destruct (n eq_refl)]. + destruct (error.bool_dec tff tff) as [Htff | n]; [|destruct (n eq_refl)]. + destruct (stype_dec A A) as [HA | n]; [|destruct (n eq_refl)]. + destruct (stype_dec B B) as [HB | n]; [|destruct (n eq_refl)]. + assert (HA = eq_refl) by apply stype_refl; subst. + assert (HB = eq_refl) by apply stype_refl; subst. + assert (Htff = eq_refl) by (apply Eqdep_dec.UIP_dec; apply error.bool_dec); subst. + assert (Hst = eq_refl) by apply st_refl; subst. + reflexivity. +Qed. + +Definition dig0dug0_opt {st tff A C} (i : instruction_seq st tff A C) : + Datatypes.option (instruction_seq st tff A C) + := + match i with + | Tail_fail i => + let 'existT _ _ i := hide_tf i in + match i with + | Instruction_seq i => cast_instruction_seq_opt i + | _ => None + end + | @SEQ st' A' B _ _ i1 i2 => + let 'existT _ _ i1 := hide_ntf i1 in + let? i1' := + match i1 return Datatypes.option (instruction_seq st' false A' B) with + | DIP 0 _ i => cast_instruction_seq_opt i + | Instruction_seq i => cast_instruction_seq_opt i + | Instruction_opcode op => + match op with + | @DIG _ 0 nil S2 a _ => + cast_instruction_seq_opt (@NOOP st' (a ::: S2)) + | @DUG _ 0 nil S2 a _ => + cast_instruction_seq_opt (@NOOP st' (a ::: S2)) + | @DIG _ 1 (cons a nil) S2 b _ => + cast_instruction_seq_opt (SEQ (@SWAP st' a b S2) NOOP) + | @DUG _ 1 (cons a nil) S2 b _ => + cast_instruction_seq_opt (SEQ (@SWAP st' b a S2) NOOP) + | @DROP _ 0 nil B' _ => + cast_instruction_seq_opt (@NOOP st' B') + | _ => None + end + | _ => None + end in + cast_instruction_seq_opt (instruction_app i1' i2) + | _ => None + end. + + +Inductive dig0dug0_opt_rel {st} : + forall {tff A B} (i i' : instruction_seq st tff A B), Prop := +| D0D0_tf A B (i : instruction_seq st true A B) : + dig0dug0_opt_rel (Tail_fail (Instruction_seq i)) i +| D0D0_seq_is {tff A B C} + (i1 : instruction_seq st false A B) + (i2 : instruction_seq st tff B C) : + dig0dug0_opt_rel (SEQ (Instruction_seq i1) i2) (instruction_app i1 i2) +| D0D0_DIP0 {tff A B C} + (i1 : instruction_seq st false A B) + (i2 : instruction_seq st tff B C) : + dig0dug0_opt_rel (SEQ (DIP (A := nil) 0 eq_refl i1) i2) (instruction_app i1 i2) +| D0D0_DROP0 {tff A B} + (i : instruction_seq st tff A B) : + dig0dug0_opt_rel (SEQ (DROP (A := nil) 0 eq_refl) i) i +| D0D0_DIG0 {tff t A B} + (i : instruction_seq st tff (t ::: A) B) : + dig0dug0_opt_rel (SEQ (DIG 0 (S1 := nil) eq_refl) i) i +| D0D0_DUG0 {tff t A B} + (i : instruction_seq st tff (t ::: A) B) : + dig0dug0_opt_rel (SEQ (DUG 0 (S1 := nil) eq_refl) i) i +| D0D0_DIG1 {tff a b A B} + (i : instruction_seq st tff (b ::: a ::: A) B) : + dig0dug0_opt_rel (SEQ (DIG 1 (S1 := _ ::: nil) eq_refl) i) (SEQ SWAP i) +| D0D0_DUG1 {tff a b A B} + (i : instruction_seq st tff (b ::: a ::: A) B) : + dig0dug0_opt_rel (SEQ (DUG 1 (S1 := _ ::: nil) eq_refl) i) (SEQ SWAP i). + +Lemma uncons {A} (a1 a2 : A) l1 l2 : + cons a1 l1 = cons a2 l2 -> a1 = a2 /\ l1 = l2. +Proof. + intro H; injection H; auto. +Qed. + +Ltac destructable_list l := + is_var l + + match l with + | nil => idtac + | cons _ _ => idtac + end. + +Ltac mytac := + match goal with + | H : ?A |- _ => + match A with + | existT _ _ _ = existT _ _ _ => + apply error.existT_eq_3 in H + | exist _ _ _ = exist _ _ _ => + apply error.exist_eq_3 in H + | hide_tf _ = existT _ _ _ => + apply error.existT_eq_3 in H + | hide_ntf _ = existT _ _ _ => + apply error.existT_eq_3 in H + | sig _ => + destruct H + | sigT _ => + destruct H + | exists _, _ => + destruct H + | _ /\ _ => + destruct H + | Datatypes.unit => + destruct H + | eq_rec _ _ _ _ eq_refl = _ => + simpl in H + | ?x = ?y => + is_var x; subst x + | ?x = ?y => + is_var y; subst y + | ?x = ?y => + assert (H = eq_refl) + by (match type of x with + | Datatypes.bool => apply Eqdep_dec.UIP_refl_bool + | Datatypes.list type => apply Eqdep_dec.UIP_dec; + apply stype_dec + | type => apply Eqdep_dec.UIP_dec; + apply type_dec + | Datatypes.nat => apply Eqdep_dec.UIP_dec; + decide equality + end); + subst H + | cons ?a1 ?l1 = cons ?a2 ?l2 => + (destructable_list l1 + destructable_list l2); + assert (a1 = a2 /\ l1 = l2) by (apply uncons; exact H) + | Some _ = Some _ => + apply unsome in H + | Some _ = None => discriminate + | cast_instruction_seq_opt _ = _ => + rewrite cast_instruction_seq_same in H + | error.opt_bind (Some _) _ = _ => + simpl in H + | error.opt_bind None _ = _ => + simpl in H + | error.opt_bind _ _ = Some _ => + apply bind_some in H + | error.opt_bind (cast_instruction_seq_opt _) _ = _ => + rewrite cast_instruction_seq_same in H + end + end. + +Lemma dig0dug0_opt_dig0dug0 {st tff A C} (i i' : instruction_seq st tff A C) : + dig0dug0_opt i = Some i' <-> dig0dug0_opt_rel i i'. +Proof. + split. + - destruct i; try discriminate; unfold dig0dug0_opt. + + case_eq (hide_tf i). + intros tff i0 He Hi0. + destruct i0; try discriminate. + repeat mytac. + constructor. + + case_eq (hide_ntf i). + intros tff1 i1 He Hi1. + destruct i1; try discriminate. + * repeat mytac. + constructor. + * destruct n; try discriminate. + destruct A; try discriminate. + repeat mytac. + constructor. + * destruct o; try discriminate; destruct n as [|[|n]]; try discriminate. + -- destruct S1; try discriminate. + repeat mytac. + constructor. + -- destruct S1 as [|b [|]]; try discriminate. + repeat mytac. + constructor. + -- destruct S1; try discriminate. + repeat mytac. + constructor. + -- destruct S1 as [|b [|]]; try discriminate. + repeat mytac. + constructor. + -- destruct A; try discriminate. + repeat mytac. + constructor. + - intro Hi; destruct Hi; unfold dig0dug0_opt, hide_tf, hide_ntf; + repeat (rewrite cast_instruction_seq_same; simpl); reflexivity. +Qed. + +Definition dig0dug0_aux {st tff A B} (i : instruction_seq st tff A B) : instruction_seq st tff A B := + opt_get (dig0dug0_opt i) i. + +Definition dig0dug0 {st tff A B} (i : instruction_seq st tff A B) : instruction_seq st tff A B := + visit_instruction_seq (@dig0dug0_aux) i. + +Lemma untyped_instruction_app_NOOP : + forall i, untyped_syntax.instruction_app i untyped_syntax.NOOP = i. +Proof. + induction i. + - reflexivity. + - simpl; f_equal; assumption. +Qed. + +Lemma untype_instruction_seq_app_aux {st tff1 tff2 A B C} + (i1 : instruction_seq st tff1 A B) + (i2 : instruction_seq st tff2 B C) H : + untyper.untype_instruction_seq untyper.untype_Optimized (instruction_app_aux i1 H i2) = + untyped_syntax.instruction_app + (untyper.untype_instruction_seq untyper.untype_Optimized i1) + (untyper.untype_instruction_seq untyper.untype_Optimized i2). +Proof. + induction i1; simpl. + - reflexivity. + - discriminate. + - f_equal. + apply IHi1. +Qed. + +Lemma untype_instruction_seq_app {st tff A B C} + (i1 : instruction_seq st false A B) + (i2 : instruction_seq st tff B C) : + untyper.untype_instruction_seq untyper.untype_Optimized (i1;;; i2) = + untyped_syntax.instruction_app + (untyper.untype_instruction_seq untyper.untype_Optimized i1) + (untyper.untype_instruction_seq untyper.untype_Optimized i2). +Proof. + apply untype_instruction_seq_app_aux. +Qed. + +Lemma untype_dig0dug0 : untype_fun_seq (@dig0dug0) (optimizer.dig0dug0). +Proof. + unfold untype_fun_seq, dig0dug0, optimizer.dig0dug0. + apply untype_visit_instruction_seq; [| reflexivity]. + intros st tff A B i; simpl. + unfold dig0dug0_aux. + case_eq (dig0dug0_opt i). + - intros i' Hi. + apply dig0dug0_opt_dig0dug0 in Hi. + destruct Hi; simpl; try reflexivity; + try (symmetry; apply untyped_instruction_app_NOOP); + try apply untype_instruction_seq_app. + - intro HN. + simpl. + destruct i; try reflexivity. + + unfold dig0dug0_opt in HN. + case_eq (hide_tf i). + intros tff i' He. + rewrite He in HN. + destruct i'; try discriminate; repeat mytac; try reflexivity. + destruct tffa; try discriminate. + repeat mytac; simpl in *; repeat mytac; reflexivity. + + unfold dig0dug0_opt in HN. + case_eq (hide_ntf i). + intros tff1 i' He. + rewrite He in HN. + apply error.existT_eq_3 in He. + destruct He as (Htff', Hi). + destruct i'; try discriminate; + try (assert (Htff' = eq_refl) by apply Eqdep_dec.UIP_refl_bool; + subst Htff'; simpl in Hi; subst; reflexivity). + * repeat mytac. + * repeat mytac. + destruct tffa; simpl in *; repeat mytac; reflexivity. + * destruct n; destruct A as [|a A]; try discriminate; repeat mytac; + reflexivity. + * repeat mytac. + destruct o; try reflexivity. + -- destruct n as [|[|n]]; destruct S1 as [|a [|b S1]]; + try discriminate; repeat mytac; reflexivity. + -- destruct n as [|[|n]]; destruct S1 as [|a [|b S1]]; + try discriminate; repeat mytac; reflexivity. + -- destruct n as [|n]; destruct A as [|a A]; + try discriminate; repeat mytac; reflexivity. +Qed. + +(* Destructors for types instruction_seq, instruction, and opcode *) + +Definition unseq {st tff A C} (i : instruction_seq st tff A C): + Datatypes.option (sigT (fun B1 => + (sigT (fun B2 => + instruction st false A B1 * + instruction_seq st tff B2 C))))%type := + match i with + | NOOP => None + | Tail_fail _ => None + | SEQ i1 i2 => + Some (existT _ _ (existT _ _ (i1, i2))) + end. + +Definition unseq_fst {st tff A C} (i : instruction_seq st tff A C): + Datatypes.option (sigT (fun A => + (sigT (fun B => + instruction st false A B))))%type := + match i with + | SEQ i1 i2 => + Some (existT _ _ (existT _ _ i1)) + | _ => None + end. + +Definition unseq_snd {st tff A C} (i : instruction_seq st tff A C): + Datatypes.option (sigT (fun B => + (sigT (fun C => + instruction_seq st tff B C))))%type := + match i with + | SEQ i1 i2 => + Some (existT _ _ (existT _ _ i2)) + | _ => None + end. + +Lemma unseq_seq {st tff A B C} (i : instruction_seq st tff A C) i1 i2 : + unseq i = Some (existT _ B (existT _ B (i1, i2))) <-> i = SEQ i1 i2. +Proof. + split. + - destruct i; simpl; intro; try discriminate. + apply unsome in H. + apply error.existT_eq_3 in H. + destruct H as (He, H). + subst B0. + simpl in H. + apply error.existT_eq_3 in H. + destruct H as (He, H). + assert (He = eq_refl) by (apply Eqdep_dec.UIP_dec; apply stype_dec). + subst He. + simpl in H. + congruence. + - intro; subst i. + simpl. + reflexivity. +Qed. + +Definition unopcode {st tff A B} (i : instruction st tff A B) : + Datatypes.option (@opcode st A B) := + match i with + | Instruction_opcode op => Some op + | _ => None + end. + +Lemma unopcode_opcode {st tff A B} (i : instruction st tff A B) o (H : false = tff) : + unopcode i = Some o <-> + i = eq_rec false (fun tff => instruction st tff A B) o tff H. +Proof. + split. + - destruct i; simpl; intro; try discriminate. + apply unsome in H0. + subst o0. + assert (H = eq_refl) by apply Eqdep_dec.UIP_refl_bool. + subst H. + reflexivity. + - subst tff. + simpl. + intro; subst i. + reflexivity. +Qed. + +Definition unswap_opcode {st A B} (op : @opcode st A B) : Datatypes.option Datatypes.unit := + match op with + | SWAP => Some tt + | _ => None + end. + +Definition unswap {st tff A B} (i : instruction st tff A B) : Datatypes.option Datatypes.unit := + let? op := unopcode i in unswap_opcode op. + +(* SWAP-SWAP *) + +Definition swapswap_opt {st tff A D} (i : instruction_seq st tff A D) : + Datatypes.option (instruction_seq st tff A D) := + let? existT _ _ (existT _ _ i1) := unseq_fst i in + let? existT _ _ (existT _ _ i23) := unseq_snd i in + let '(existT _ _ i1) := hide_ntf i1 in + let? existT _ _ (existT _ _ i2) := unseq_fst i23 in + let '(existT _ _ i2) := hide_ntf i2 in + let? existT _ _ (existT _ _ i3) := unseq_snd i23 in + let? tt := unswap i1 in + let? tt := unswap i2 in + cast_instruction_seq_opt i3. + +Inductive swapswap_rel {st tff} : + forall {A B} (i i' : instruction_seq st tff A B), Prop := +| Swapswap_intro {a b A B} (i : instruction_seq st tff (a ::: b ::: A) B) : + swapswap_rel (SEQ SWAP (SEQ SWAP i)) i. + +Lemma swapswap_opt_swapswap {st tff A D} (i i' : instruction_seq st tff A D) : + swapswap_opt i = Some i' <-> swapswap_rel i i'. +Proof. + split. + - unfold swapswap_opt. + intro H. + apply bind_some in H; destruct H as ((A1, (B1, i1)), (He1, H)). + apply bind_some in H; destruct H as ((A23, (B23, i23)), (He23, H)). + case_eq (hide_ntf i1); intros tff1 i1' Hi1'; rewrite Hi1' in H. + apply bind_some in H; destruct H as ((A2, (B2, i2)), (He2, H)). + case_eq (hide_ntf i2); intros tff2 i2' Hi2'; rewrite Hi2' in H. + apply bind_some in H; destruct H as ((A3, (B3, i3)), (He3, H)). + + destruct i1'; try discriminate. + destruct o; try discriminate. + simpl in H. + + destruct i2'; try discriminate. + destruct o; try discriminate. + simpl in H. + + destruct i; try discriminate. + destruct i23; try discriminate. + simpl in *. + repeat mytac. + constructor. + - intro H. + destruct H. + simpl. + unfold swapswap_opt; simpl. + apply cast_instruction_seq_same. +Qed. + +Definition swapswap_aux {st tff A D} (i : instruction_seq st tff A D) : + instruction_seq st tff A D := + opt_get (swapswap_opt i) i. + +Definition swapswap {st tff A B} (i : instruction_seq st tff A B) : instruction_seq st tff A B := + visit_instruction_seq (@swapswap_aux) i. + +Lemma untype_inversion_seq {st tff A C um} {i : instruction_seq st tff A C} {ui1 ui2} : + untyper.untype_instruction_seq um i = untyped_syntax.SEQ ui1 ui2 -> + (exists (H : tff = true) i', + eq_rec _ (fun tff => instruction_seq st tff A C) i _ H = Tail_fail i') + \/ + (exists B (i1 : instruction st false A B) i2, i = SEQ i1 i2). +Proof. + destruct i. + - discriminate. + - intro H; left. + exists eq_refl. + exists i. + reflexivity. + - intro H; right. + repeat eexists. +Qed. + +Lemma untype_inversion_swap {st tff A B um} (i : instruction st tff A B) : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode untyped_syntax.SWAP -> + exists a b SA + (H : tff = false) + (HA : A = a ::: b ::: SA) + (HB : B = b ::: a ::: SA), + eq_rec + _ + (fun A => instruction st false A (b ::: a ::: SA)) + (eq_rec + _ + (fun B => instruction st false A B) + (eq_rec _ (fun tff => instruction st tff A B) i _ H) _ HB) _ HA + = Instruction_opcode SWAP. +Proof. + destruct i; try discriminate. + destruct o; try discriminate. + simpl. + intros _. + do 3 eexists. + do 3 (exists eq_refl). + reflexivity. +Qed. + +Lemma untype_inversion_dig {st tff A B um} (i : instruction st tff A B) n : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode (untyped_syntax.DIG n) -> + exists S1 S2 t + (H : tff = false) + (HA : A = S1 +++ t ::: S2) + (HB : B = t ::: S1 +++ S2) + (Hn : n = List.length S1), + eq_rec + _ + (fun A => instruction st false A (t ::: S1 +++ S2)) + (eq_rec + _ + (fun B => instruction st false A B) + (eq_rec _ (fun tff => instruction st tff A B) i _ H) _ HB) _ HA + = Instruction_opcode (@DIG _ (List.length S1) S1 S2 t eq_refl). +Proof. + destruct i; try discriminate. + destruct o; try discriminate. + simpl. + intro H. + injection H. + intro; subst; clear H. + do 3 eexists. + do 4 (exists eq_refl). + reflexivity. +Qed. + +Lemma untype_inversion_dug {st tff A B um} (i : instruction st tff A B) n : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode (untyped_syntax.DUG n) -> + exists S1 S2 t + (H : tff = false) + (HA : A = t ::: S1 +++ S2) + (HB : B = S1 +++ t ::: S2) + (Hn : n = List.length S1), + eq_rec + _ + (fun A => instruction st false A (S1 +++ t ::: S2)) + (eq_rec + _ + (fun B => instruction st false A B) + (eq_rec _ (fun tff => instruction st tff A B) i _ H) _ HB) _ HA + = Instruction_opcode (@DUG _ (List.length S1) S1 S2 t eq_refl). +Proof. + destruct i; try discriminate. + destruct o; try discriminate. + simpl. + intro H. + injection H. + intro; subst; clear H. + do 3 eexists. + do 4 (exists eq_refl). + reflexivity. +Qed. + +Lemma untype_swapswap : untype_fun_seq (@swapswap) (optimizer.swapswap). +Proof. + unfold untype_fun_seq, swapswap, optimizer.swapswap. + apply untype_visit_instruction_seq; [| reflexivity]. + intros st tff A D i; simpl. + unfold swapswap_aux. + unfold opt_get. + case_eq (swapswap_opt i). + - intros i' H. + rewrite swapswap_opt_swapswap in H. + destruct H. + reflexivity. + - intro H. + unfold swapswap_opt in H. + case_eq (untyper.untype_instruction_seq untyper.untype_Optimized i); + try reflexivity. + intros ui1 ui23 Hi. + destruct ui1; try reflexivity. + destruct o; try reflexivity. + destruct ui23; try reflexivity. + destruct i0; try reflexivity. + destruct o; try reflexivity. + exfalso. + generalize (untype_inversion_seq Hi). + intro Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (B, (i1, (i23, Hi123)))]. + * repeat mytac. + discriminate. + * subst i. + simpl in Hi. + injection Hi. + intros Hi23 Hi1. + generalize (untype_inversion_seq Hi23). + intros Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (C, (i2, (i3, Hi23')))]. + -- repeat mytac. + injection Hi23. + intros Hui23 Hi'. + apply untype_inversion_swap in Hi'. + repeat mytac. + discriminate. + -- repeat mytac. + injection Hi23. + intros Hi3 Hi2. + apply untype_inversion_swap in Hi1. + apply untype_inversion_swap in Hi2. + repeat mytac. + simpl in H. + repeat mytac. +Qed. + +(* DIG n - DUG n *) + + +Definition undig_opcode {st A B} (op : @opcode st A B) : Datatypes.option Datatypes.nat := + match op with + | DIG n _ => Some n + | _ => None + end. + +Definition undug_opcode {st A B} (op : @opcode st A B) : Datatypes.option Datatypes.nat := + match op with + | DUG n _ => Some n + | _ => None + end. + +Definition undig {st tff A B} (i : instruction st tff A B) : Datatypes.option Datatypes.nat := + let? o := unopcode i in undig_opcode o. + +Definition undug {st tff A B} (i : instruction st tff A B) : Datatypes.option Datatypes.nat := + let? o := unopcode i in undug_opcode o. + +Lemma untype_inversion_undig {st tff A B um} (i : instruction st tff A B) n : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode (untyped_syntax.DIG n) -> + undig i = Some n. +Proof. + intro H. + apply untype_inversion_dig in H. + repeat mytac. + reflexivity. +Qed. + +Lemma untype_inversion_undug {st tff A B um} (i : instruction st tff A B) n : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode (untyped_syntax.DUG n) -> + undug i = Some n. +Proof. + intro H. + apply untype_inversion_dug in H. + repeat mytac. + reflexivity. +Qed. + +Definition digndugn_opt {st tff A D} (i : instruction_seq st tff A D) : + Datatypes.option (instruction_seq st tff A D) := + let? existT _ _ (existT _ _ i1) := unseq_fst i in + let? existT _ _ (existT _ _ i23) := unseq_snd i in + let '(existT _ _ i1) := hide_ntf i1 in + let? existT _ _ (existT _ _ i2) := unseq_fst i23 in + let '(existT _ _ i2) := hide_ntf i2 in + let? existT _ _ (existT _ _ i3) := unseq_snd i23 in + let? n1 := undig i1 in + let? n2 := undug i2 in + if (n1 =? n2) then cast_instruction_seq_opt i3 else None. + +Inductive digndugn_rel {st tff} : + forall {A B} (i i' : instruction_seq st tff A B), Prop := +| DignDugn_intro {S1 S2 t B} (i : instruction_seq st tff (S1 +++ t ::: S2) B) : + digndugn_rel + (SEQ (@DIG st (List.length S1) S1 S2 t eq_refl) + (SEQ (@DUG st (List.length S1) S1 S2 t eq_refl) i)) i. + +Lemma digndugn_opt_digndugn {st tff A D} (i i' : instruction_seq st tff A D) : + digndugn_opt i = Some i' <-> + digndugn_rel i i'. +Proof. + split. + - unfold digndugn_opt. + intro H. + apply bind_some in H; destruct H as ((A1, (B1, i1)), (He1, H)). + apply bind_some in H; destruct H as ((A23, (B23, i23)), (He23, H)). + case_eq (hide_ntf i1); intros tff1 i1' Hi1'; rewrite Hi1' in H. + apply bind_some in H; destruct H as ((A2, (B2, i2)), (He2, H)). + case_eq (hide_ntf i2); intros tff2 i2' Hi2'; rewrite Hi2' in H. + apply bind_some in H; destruct H as ((A3, (B3, i3)), (He3, H)). + + destruct i1'; try discriminate. + destruct o; try discriminate. + simpl in H. + + destruct i2'; try discriminate. + destruct o; try discriminate. + simpl in H. + + case_eq (n =? n0); intro Hn; rewrite Hn in H; [|discriminate]. + + destruct i; try discriminate. + destruct i23; try discriminate. + simpl in *. + + repeat mytac. + match goal with | H : _ ::: _ +++ _ = _ ::: _ +++ _ |- _ => injection H end. + intros Happ Ht. + apply beq_nat_true in Hn. + symmetry in Hn. + apply untyper.app_length_inv in Happ; [|assumption]. + repeat mytac. + constructor. + - intro H. + destruct H. + simpl. + unfold digndugn_opt; simpl. + rewrite Nat.eqb_refl. + apply cast_instruction_seq_same. +Qed. + +Definition digndugn_aux {st tff A D} (i : instruction_seq st tff A D) : + instruction_seq st tff A D := + opt_get (digndugn_opt i) i. + +Definition digndugn {st tff A B} (i : instruction_seq st tff A B) : instruction_seq st tff A B := + visit_instruction_seq (@digndugn_aux) i. + +Lemma untype_digndugn : untype_fun_seq (@digndugn) (optimizer.digndugn). +Proof. + unfold untype_fun_seq, digndugn, optimizer.digndugn. + apply untype_visit_instruction_seq; [| reflexivity]. + intros st tff A D i; simpl. + unfold digndugn_aux. + unfold opt_get. + case_eq (digndugn_opt i). + - intros i' H. + rewrite digndugn_opt_digndugn in H. + destruct H. + simpl. + rewrite Nat.eqb_refl. + reflexivity. + - intro H. + unfold digndugn_opt in H. + case_eq (untyper.untype_instruction_seq untyper.untype_Optimized i); + try reflexivity. + intros ui1 ui23 Hi. + destruct ui1; try reflexivity. + destruct o; try reflexivity. + destruct ui23; try reflexivity. + destruct i0; try reflexivity. + destruct o; try reflexivity. + case_eq (n =? n0); intro Hn; try reflexivity. + exfalso. + generalize (untype_inversion_seq Hi). + intro Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (B, (i1, (i23, Hi123)))]. + * repeat mytac. + discriminate. + * subst i. + simpl in Hi. + injection Hi. + intros Hi23 Hi1. + generalize (untype_inversion_seq Hi23). + intros Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (C, (i2, (i3, Hi23')))]. + -- repeat mytac. + injection Hi23. + intros Hui23 Hi'. + apply untype_inversion_dug in Hi'. + repeat mytac. + discriminate. + -- repeat mytac. + injection Hi23. + intros Hi3 Hi2. + assert (undig i1 = Some n) as Hni1 + by (eapply untype_inversion_undig; eassumption). + assert (undug i2 = Some n0) as Hni2 + by (eapply untype_inversion_undug; eassumption). + simpl in H. + rewrite Hni1 in H. + rewrite Hni2 in H. + simpl in H. + rewrite Hn in H. + apply untype_inversion_dig in Hi1. + apply untype_inversion_dug in Hi2. + repeat mytac. + match goal with | H : _ ::: ?S1 +++ _ = _ ::: ?S2 +++ _ |- _ => + rename H into Hl end. + injection Hl; intros Happ Ht. + apply beq_nat_true in Hn. + symmetry in Hn. + apply untyper.app_length_inv in Happ; [|assumption]. + repeat mytac. +Qed. + +(* PUSH - DROP *) + +Definition unpush {st tff A B} (i : instruction st tff A B) : Datatypes.option Datatypes.unit := + match i with + | PUSH _ _ => Some tt + | _ => None + end. + +Lemma untype_inversion_push {st tff A B um} (i : instruction st tff A B) a x : + untyper.untype_instruction um i = + untyped_syntax.PUSH a x -> + exists y (H : tff = false) (HB : B = a ::: A), + untyper.untype_data um y = x /\ + eq_rec + _ + (fun B => instruction st false A B) + (eq_rec _ (fun tff => instruction st tff A B) i _ H) _ HB + = PUSH a y. +Proof. + destruct i; try discriminate. + simpl. + intro H. + injection H. + intros; subst; clear H. + eexists. + do 2 (exists eq_refl). + split; reflexivity. +Qed. + +Definition undrop_opcode {st A B} (i : @opcode st A B) : Datatypes.option Datatypes.nat := + match i with + | DROP n _ => Some n + | _ => None + end. + +Definition undrop {st tff A B} (i : instruction st tff A B) : Datatypes.option Datatypes.nat := + let? o := unopcode i in undrop_opcode o. + + +Lemma untype_inversion_drop {st tff A B um} (i : instruction st tff A B) n : + untyper.untype_instruction um i = + untyped_syntax.instruction_opcode (untyped_syntax.DROP n) -> + exists S1 + (H : tff = false) + (HA : A = S1 +++ B) + (Hn : n = List.length S1), + eq_rec + _ + (fun A => instruction st false A B) + (eq_rec _ (fun tff => instruction st tff A B) i _ H) _ HA + = Instruction_opcode (@DROP _ (List.length S1) S1 B eq_refl). +Proof. + destruct i; try discriminate. + destruct o; try discriminate. + simpl. + intro H. + injection H. + intro; subst; clear H. + eexists. + do 3 (exists eq_refl). + reflexivity. +Qed. + +Definition take_one_opt (A : stack_type) : + Datatypes.option (sigT (fun a : type => + sig (fun B : stack_type => A = a ::: B))) := + match A with + | nil => None + | cons a A => Some (existT _ a (exist _ A eq_refl)) + end. + +Fixpoint take_n_opt (A : stack_type) n : + Datatypes.option (sig (fun S1 : stack_type => List.length S1 = n)) := + match n with + | 0 => Some (exist _ nil eq_refl) + | S n => + let? existT _ a (exist _ B H) := take_one_opt A in + let? exist _ S1 H := take_n_opt B n in + Some (exist _ (a ::: S1) (f_equal S H)) + end. + +Lemma take_n_opt_length S1 S2 : take_n_opt (S1 +++ S2) (Datatypes.length S1) = + Some (exist _ S1 eq_refl). +Proof. + induction S1; simpl. + - reflexivity. + - rewrite IHS1; reflexivity. +Qed. + +Definition pushdrop_opt {st tff A D} (i : instruction_seq st tff A D) : + Datatypes.option (instruction_seq st tff A D) := + let? existT _ _ (existT _ _ i1) := unseq_fst i in + let? existT _ _ (existT _ _ i23) := unseq_snd i in + let '(existT _ _ i1) := hide_ntf i1 in + let? existT _ _ (existT _ _ i2) := unseq_fst i23 in + let '(existT _ _ i2) := hide_ntf i2 in + let? existT _ B (existT _ _ i3) := unseq_snd i23 in + let? tt := unpush i1 in + let? n := undrop i2 in + match n with + | 0 => None + | 1 => cast_instruction_seq_opt i3 + | S n => + let? exist _ S1 H1 := take_n_opt A n in + cast_instruction_seq_opt (SEQ (@DROP st n S1 B H1) i3) + end. + +Inductive pushdrop_rel {st tff} : + forall {A B} (i i' : instruction_seq st tff A B), Prop := +| PushDrop_1 {A B t x} (i : instruction_seq st tff A B) : + pushdrop_rel + (SEQ (PUSH t x) (SEQ (@DROP _ 1 (cons t nil) A eq_refl) i)) i +| PushDrop_S {t2 S1 S2 B t1 x} (i : instruction_seq st tff S2 B) : + pushdrop_rel + (SEQ (PUSH t1 x) (SEQ (@DROP _ (S (S (List.length S1))) (cons t1 (cons t2 S1)) S2 eq_refl) i)) + (SEQ (@DROP _ (S (List.length S1)) (cons t2 S1) S2 eq_refl) i). + +Lemma pushdrop_opt_pushdrop {st tff A D} (i i' : instruction_seq st tff A D) : + pushdrop_opt i = Some i' <-> pushdrop_rel i i'. +Proof. + split. + - unfold pushdrop_opt. + intro H. + apply bind_some in H; destruct H as ((A1, (B1, i1)), (He1, H)). + apply bind_some in H; destruct H as ((A23, (B23, i23)), (He23, H)). + case_eq (hide_ntf i1); intros tff1 i1' Hi1'; rewrite Hi1' in H. + apply bind_some in H; destruct H as ((A2, (B2, i2)), (He2, H)). + case_eq (hide_ntf i2); intros tff2 i2' Hi2'; rewrite Hi2' in H. + apply bind_some in H; destruct H as ((A3, (B3, i3)), (He3, H)). + + destruct i1'; try discriminate. + simpl in H. + + destruct i2'; try discriminate. + destruct o; try discriminate. + simpl in H. + + destruct n as [|[|n]]; destruct A1 as [|t1[|t2 A1]]; try discriminate. + + destruct i; try discriminate. + destruct i23; try discriminate. + simpl in *. + repeat mytac. + constructor. + + destruct i; try discriminate. + destruct i23; try discriminate. + simpl in *. + injection e; intro. + repeat mytac. + rewrite take_n_opt_length in H1. + simpl in *. + repeat mytac. + simpl. + constructor. + - intro H. + destruct H. + + simpl. + unfold pushdrop_opt; simpl. + apply cast_instruction_seq_same. + + simpl. + unfold pushdrop_opt; simpl. + rewrite take_n_opt_length. + simpl. + apply cast_instruction_seq_same. +Qed. + +Definition pushdrop_aux {st tff A B} (i : instruction_seq st tff A B) + : instruction_seq st tff A B := + opt_get (pushdrop_opt i) i. + +Definition pushdrop {st tff A B} (i : instruction_seq st tff A B) := + visit_instruction_seq (@pushdrop_aux) i. + +Lemma untype_pushdrop : untype_fun_seq (@pushdrop) (optimizer.push_drop). +Proof. + unfold untype_fun_seq, pushdrop, optimizer.push_drop. + apply untype_visit_instruction_seq; [| reflexivity]. + intros st tff A D i; simpl. + unfold pushdrop_aux. + unfold opt_get. + case_eq (pushdrop_opt i). + - intros i' H. + rewrite pushdrop_opt_pushdrop in H. + destruct H; reflexivity. + - intro H. + unfold pushdrop_opt in H. + case_eq (untyper.untype_instruction_seq untyper.untype_Optimized i); + try reflexivity. + intros ui1 ui23 Hi. + destruct ui1; try reflexivity. + destruct ui23; try reflexivity. + destruct i0; try reflexivity. + destruct o; try reflexivity. + destruct n as [|n]; try reflexivity. + exfalso. + generalize (untype_inversion_seq Hi). + intro Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (B, (i1, (i23, Hi123)))]. + * repeat mytac. + discriminate. + * subst i. + simpl in Hi. + injection Hi. + intros Hi23 Hi1. + generalize (untype_inversion_seq Hi23). + intros Hiinv. + destruct Hiinv as [(Htff, (i', Hi')) | (C, (i2, (i3, Hi23')))]. + -- repeat mytac. + injection Hi23. + intros Hui23 Hi'. + apply untype_inversion_drop in Hi'. + repeat mytac. + discriminate. + -- repeat mytac. + injection Hi23. + intros Hi3 Hi2. + apply untype_inversion_push in Hi1. + apply untype_inversion_drop in Hi2. + repeat mytac. + match goal with H : S _ = Datatypes.length ?l |- _ => + rename l into B; rename H into HB end. + destruct B as [| a [| b B]]; [discriminate| |]. + ++ simpl in *. + injection HB; intro. + repeat mytac. + simpl in H. + repeat mytac. + ++ simpl in *. + injection HB; intro. + repeat mytac. + simpl in H. + rewrite take_n_opt_length in H. + simpl in H. + repeat mytac. +Qed. + +Definition cleanup {st tff A B} (i : instruction_seq st tff A B) + : instruction_seq st tff A B := + pushdrop + (swapswap + (digndugn + (dig0dug0 i))). + +Lemma untype_cleanup : untype_fun_seq (@cleanup) (optimizer.cleanup). +Proof. + intros st tff A B i. + unfold cleanup, optimizer.cleanup. + rewrite (@untype_pushdrop st tff A B); f_equal. + rewrite (@untype_swapswap st tff A B); f_equal. + rewrite (@untype_digndugn st tff A B); f_equal. + rewrite (@untype_dig0dug0 st tff A B); f_equal. +Qed. + + +Module Semantics_Preservation (C : semantics.ContractContext). + Module S := semantics.Semantics C. + Import S. + + Definition same_semantics + (F : forall st tff A B, instruction_seq st tff A B -> + instruction_seq st tff A B) + := + forall st tff env A B fuel i stA, + Bool.Is_true (error.success (eval_seq env i fuel stA)) -> + eval_seq env (F st tff A B i) fuel stA = eval_seq env i fuel stA. + + Lemma eval_seq_SEQ st tff env A B C + (i1 : instruction st false A B) + (i2 : instruction_seq st tff B C) fuel SA : + eval_seq env (SEQ i1 i2) fuel SA = + let! SB := eval env i1 fuel SA in + eval_seq env i2 fuel SB. + Proof. + unfold eval_seq. + destruct fuel; reflexivity. + Qed. + + Lemma eval_fail_and_seq : + (forall st A B (i : instruction st true A B) + fuel env stA, ~ Bool.Is_true (error.success (eval env i fuel stA))) * + (forall st A B (i : instruction_seq st true A B) + fuel env stA, ~ Bool.Is_true (error.success (eval_seq env i fuel stA))). + Proof. + apply tail_fail_induction_and_seq; intros; (destruct fuel as [|fuel]; [simpl; auto|]); simpl. + - destruct stA as (x, stA); simpl. + auto. + - destruct stA as (x, stA); simpl. + destruct (if_family_destruct f x); simpl; [apply H | apply H0]. + - rewrite eval_seq_SEQ. + intro Hs; apply error.success_bind in Hs. + destruct Hs as (stB, (Hi1, Hs)). + apply H in Hs. + assumption. + - apply H. + - apply H. + Qed. + + Lemma eval_fail st A B (i : instruction st true A B) fuel env stA : + ~ Bool.Is_true (error.success (eval env i fuel stA)). + Proof. + apply eval_fail_and_seq. + Qed. + + Lemma eval_fail_seq st A B (i : instruction_seq st true A B) fuel env stA : + ~ Bool.Is_true (error.success (eval_seq env i fuel stA)). + Proof. + apply eval_fail_and_seq. + Qed. + + Lemma same_semantics_visit_seq_aux F (HF : same_semantics F) + (HNOOP : forall st A, F st _ A A NOOP = NOOP) : + (forall st tff env A B fuel (i : instruction st tff A B) stA, + Bool.Is_true (error.success (eval env i fuel stA)) -> + eval env (visit_instruction F i) fuel stA = eval env i fuel stA) -> + same_semantics (@visit_instruction_seq F). + Proof. + intros Heval st tff env A B fuel i stA Hsucc. + induction i. + - simpl. + rewrite HNOOP. + reflexivity. + - simpl. + apply eval_fail in Hsucc. + contradiction. + - simpl. + rewrite eval_seq_SEQ in Hsucc. + apply error.success_bind in Hsucc. + destruct Hsucc as (stB, (Hi, Hsucc)). + transitivity + (eval_seq env (SEQ + (visit_instruction F i) + (visit_instruction_seq F i0)) fuel stA). + + apply HF. + rewrite eval_seq_SEQ. + specialize (IHi env stB Hsucc). + rewrite Heval; rewrite Hi; [|constructor]. + simpl. + rewrite IHi. + assumption. + + do 2 rewrite eval_seq_SEQ. + rewrite Heval. + * rewrite Hi. + simpl. + apply IHi. + exact Hsucc. + * rewrite Hi. + simpl. + constructor. + Defined. + + Fixpoint same_semantics_visit F (HF : same_semantics F) (HNOOP : forall st A, F st false A A NOOP = NOOP) + st tff env A B fuel (i : instruction st tff A B) stA {struct fuel} : + Bool.Is_true (error.success (eval env i fuel stA)) -> + eval env (visit_instruction F i) fuel stA = + eval env i fuel stA. + Proof. + specialize (same_semantics_visit_seq_aux F HF HNOOP (same_semantics_visit F HF HNOOP)). + unfold same_semantics. + intros Hseq. + destruct fuel as [|fuel]; [reflexivity|]; destruct i; try reflexivity. + + apply Hseq; try assumption. + + destruct stA as (x, SA); + simpl; destruct (if_family_destruct i x); + intro Hsucc; apply Hseq; exact Hsucc. + + destruct stA as (ab, SA); simpl; destruct (loop_family_destruct i ab) as [a|b]; + intro Hsucc. + * apply error.success_bind in Hsucc. + destruct Hsucc as ((x, SA'), (Hret,Hsucc)). + unfold eval_seq in Hseq. + rewrite Hseq. + -- rewrite Hret; simpl. + unfold stack_type in Hret; rewrite Hret; simpl. + generalize (same_semantics_visit F HF HNOOP _ _ env _ _ fuel (LOOP_ i i0)); + intro Hv. + simpl in Hv. + apply Hv. + assumption. + -- unfold stack_type in Hret. + rewrite Hret. + constructor. + * reflexivity. + + destruct stA as (x, SA); simpl. + destruct (iter_destruct (iter_elt_type collection i) collection (iter_variant_field collection i)) as [(a, y)|]; intro Hsucc. + * apply error.success_bind in Hsucc. + destruct Hsucc as (z, (Hret,Hsucc)). + unfold stack_type. + unfold eval_seq in Hseq. + rewrite Hseq. + -- generalize (same_semantics_visit F HF HNOOP _ _ env _ _ fuel (ITER i0)); + intro Hv. + simpl in Hv. + unfold stack_type in Hret. + rewrite Hret. + simpl. + apply Hv. + assumption. + -- unfold stack_type in Hret. + rewrite Hret. + constructor. + * reflexivity. + + destruct stA as (x, SA); simpl. + destruct (map_destruct (map_in_type collection b i) b collection (map_out_collection_type collection b i) (map_variant_field collection b i) x) as [(a, y)|]; intro Hsucc. + * apply error.success_bind in Hsucc. + destruct Hsucc as ((b0, SB), (Hret,Hsucc)). + unfold eval_seq in Hseq. + rewrite Hseq. + -- generalize (same_semantics_visit F HF HNOOP self_type _ env _ _ fuel (MAP i0)); + intro Hv. + simpl in Hv. + rewrite Hret. + unfold stack_type in Hret. + simpl. + simpl in Hret. + match goal with |- (let! (b1, SB0) := ?lhs in _ ) = _ => + replace lhs with (error.Return (b0, SB)) + end. + simpl. + rewrite Hv. + ++ reflexivity. + ++ apply error.success_bind_arg in Hsucc. + assumption. + -- unfold stack_type in Hret. + match goal with |- (Bool.Is_true (error.success ?lhs)) => + replace lhs with (error.Return (b0, SB)) + end. + constructor. + * reflexivity. + + simpl. + intro Hsucc. + destruct (stack_split stA) as (S1, S2). + unfold eval_seq in Hseq. + rewrite Hseq. + * reflexivity. + * unfold stack_type in Hsucc. + apply error.success_bind_arg in Hsucc. + assumption. + Qed. + + Lemma same_semantics_visit_seq F (HF : same_semantics F) (HNOOP : forall st A, F st false A A NOOP = NOOP) : + same_semantics (@visit_instruction_seq F). + Proof. + apply same_semantics_visit_seq_aux; try assumption. + apply same_semantics_visit; assumption. + Qed. + + Lemma same_semantics_opt F : + (forall st tff env A B (i i' : instruction_seq st tff A B) SA fuel, + F st tff A B i = Some i' -> + Bool.Is_true (error.success (eval_seq env i fuel SA)) -> + eval_seq env i' fuel SA = eval_seq env i fuel SA) -> + same_semantics (fun st tff A B (i : instruction_seq st tff A B) => opt_get (F st tff A B i) i). + Proof. + intros HF st tff env A B fuel i SA Hsucc. + case_eq (F st tff A B i). + - intros i' Hi'. + apply HF; assumption. + - intro; reflexivity. + Qed. + + Lemma eval_Instruction_seq_aux st tff env A B (i : instruction_seq st tff A B) fuel stA : + Bool.Is_true (error.success (eval env (Instruction_seq i) fuel stA)) -> + eval env (Instruction_seq i) fuel stA = + eval_seq env i fuel stA. + Proof. + destruct fuel. + - contradiction. + - intro Hsucc. + change (eval_seq env i fuel stA = eval_seq env i (S fuel) stA). + apply eval_seq_deterministic_le. + + omega. + + assumption. + Qed. + + Lemma eval_seq_instruction_app_aux st tff1 H1 tff2 env A B C + (i1 : instruction_seq st tff1 A B) + (i2 : instruction_seq st tff2 B C) fuel SA : + eval_seq env (instruction_app_aux i1 H1 i2) fuel SA = + let! SB := eval_seq env i1 fuel SA in + eval_seq env i2 fuel SB. + Proof. + induction i1; simpl. + - reflexivity. + - discriminate. + - unfold eval_seq. + simpl. + destruct (eval env i fuel SA); simpl. + + reflexivity. + + apply IHi1. + Qed. + + Lemma eval_seq_instruction_app st tff env A B C + (i1 : instruction_seq st false A B) + (i2 : instruction_seq st tff B C) fuel SA : + eval_seq env (i1;;;i2) fuel SA = + let! SB := eval_seq env i1 fuel SA in + eval_seq env i2 fuel SB. + Proof. + apply eval_seq_instruction_app_aux. + Qed. + + Lemma eval_Instruction_seq self_type tff env fuel A B C + (i1 : instruction_seq self_type false A B) + (i2 : instruction_seq self_type tff B C) + stA: + Bool.Is_true (error.success (eval_seq env (SEQ (Instruction_seq i1) i2) fuel stA)) -> + eval_seq env (i1;;; i2) fuel stA = + eval_seq env (SEQ (Instruction_seq i1) i2) fuel stA. + Proof. + intro Hsucc. + rewrite eval_seq_instruction_app. + rewrite eval_seq_SEQ. + rewrite eval_Instruction_seq_aux. + - reflexivity. + - rewrite eval_seq_SEQ in Hsucc. + apply error.success_bind_arg in Hsucc. + assumption. + Qed. + + Lemma same_semantics_dig0dug0 : + same_semantics (@dig0dug0). + Proof. + apply same_semantics_visit_seq. + - apply same_semantics_opt. + intros st tff env A B i i' stA fuel HS Hsucc. + apply dig0dug0_opt_dig0dug0 in HS. + destruct HS. + + apply eval_fail_seq in Hsucc. + contradiction. + + apply eval_Instruction_seq. + assumption. + + rewrite eval_seq_instruction_app. + rewrite eval_seq_SEQ. + f_equal. + unfold eval_seq in Hsucc. + apply error.success_bind in Hsucc. + destruct Hsucc as (stB, (HDIP, _)). + destruct fuel; [simpl in HDIP; discriminate|]. + simpl. + simpl in HDIP. + apply error.bind_eq_return in HDIP. + destruct HDIP as (stB', (Hi1, HstB')). + apply error.unreturn in HstB'. + subst stB'. + rewrite Hi1. + simpl. + rewrite <- Hi1. + symmetry. + apply eval_seq_deterministic_le; [omega|]. + unfold eval_seq. + unfold stack_type in Hi1. + rewrite Hi1. + constructor. + + rewrite eval_seq_SEQ. + destruct fuel; [simpl in Hsucc; contradiction|]. + reflexivity. + + rewrite eval_seq_SEQ. + destruct fuel; [simpl in Hsucc; contradiction|]. + destruct stA; reflexivity. + + rewrite eval_seq_SEQ. + destruct fuel; [simpl in Hsucc; contradiction|]. + destruct stA; reflexivity. + + rewrite eval_seq_SEQ. + destruct fuel; [simpl in Hsucc; contradiction|]. + destruct stA as (x, (y, stA)); reflexivity. + + rewrite eval_seq_SEQ. + destruct fuel; [simpl in Hsucc; contradiction|]. + destruct stA as (x, (y, stA)); reflexivity. + - reflexivity. + Qed. + + + Lemma same_semantics_swapswap : + same_semantics (@swapswap). + Proof. + apply same_semantics_visit_seq. + - apply same_semantics_opt. + intros st tff env A D i i' stA fuel HS Hsucc. + apply swapswap_opt_swapswap in HS. + destruct HS. + destruct fuel as [|fuel]; [contradiction|]. + destruct stA as (x, (y, stA)). + rewrite eval_seq_SEQ. + simpl. + rewrite eval_seq_SEQ. + simpl. + reflexivity. + - reflexivity. + Qed. + + Lemma stack_app_split (S1 S2 : Datatypes.list type) (s1 : stack S1) (s2 : stack S2) sA : + stack_split sA = (s1, s2) <-> sA = stack_app s1 s2. + Proof. + generalize s2; clear s2. + induction S1; intro s2. + - simpl. + simpl in s1. + destruct s1. + split; congruence. + - simpl. + simpl in s1. + destruct s1 as (x, s1). + simpl in sA. + destruct sA as (y, sA). + case_eq (stack_split sA). + intros s1' s2' HsA. + split. + + rewrite IHS1 in HsA. + congruence. + + intro H; injection H; intros. + subst y. + rewrite <- IHS1 in H0. + congruence. + Qed. + + Lemma same_semantics_digndugn : + same_semantics (@digndugn). + Proof. + apply same_semantics_visit_seq. + - apply same_semantics_opt. + intros st tff env A D i i' stA fuel HS Hsucc. + apply digndugn_opt_digndugn in HS. + destruct HS. + + destruct fuel as [|fuel]; [contradiction|]. + rewrite eval_seq_SEQ. + simpl. + rewrite eval_seq_SEQ. + simpl. + unfold stack_dig, stack_dug. + case_eq (stack_split stA). + intros s1 s2 HS12. + destruct s2 as (x, s2). + assert (stack_split (stack_app s1 s2) = (s1, s2)) as H. + * rewrite stack_app_split. + reflexivity. + * rewrite H. + rewrite stack_app_split in HS12. + congruence. + - reflexivity. + Qed. + + Lemma same_semantics_push_drop : + same_semantics (@pushdrop). + Proof. + apply same_semantics_visit_seq. + - apply same_semantics_opt. + intros st tff env A D i i' stA fuel HS Hsucc. + apply pushdrop_opt_pushdrop in HS. + destruct HS. + + destruct fuel as [|fuel]; [contradiction|]. + rewrite eval_seq_SEQ. + simpl. + rewrite eval_seq_SEQ. + simpl. + reflexivity. + + destruct fuel as [|fuel]; [contradiction|]. + rewrite eval_seq_SEQ. + simpl. + rewrite eval_seq_SEQ. + simpl. + rewrite eval_seq_SEQ. + simpl. + destruct stA as (y, stA). + case_eq (stack_split stA). + reflexivity. + - reflexivity. + Qed. + + Lemma same_semantics_compose F G : + same_semantics F -> + same_semantics G -> + same_semantics (fun st tff A B i => F st tff A B (G st tff A B i)). + Proof. + intros HF HG. + unfold same_semantics. + intros. + rewrite HF. + - rewrite HG. + + reflexivity. + + assumption. + - rewrite HG; assumption. + Qed. + + Lemma same_semantics_cleanup : + same_semantics (@cleanup). + Proof. + unfold cleanup. + apply same_semantics_compose; [exact same_semantics_push_drop|]. + apply same_semantics_compose; [exact same_semantics_swapswap|]. + apply same_semantics_compose; [exact same_semantics_digndugn|]. + exact same_semantics_dig0dug0. + Qed. + + Definition typecheck_and_eval_seq + (i : untyped_syntax.instruction_seq) + A B (sA : stack A) + self_type env fuel : error.M (stack B) := + let! existT _ tff i' := + typer.type_check_instruction_seq + (self_type := self_type) + (typer.type_instruction_seq typer.Optimized) + i A B in + eval_seq env i' fuel sA. + + (* If the untyped instruction sequence i can be typechecked from + stack type A to stack type B and then run successfully on stack + sA, then (optimizer.optimize i) can also be typechecked from + stack type A to stack type B and run successfully on stack sA + yielding the same result. *) + + Theorem optimize_correct : + forall i A B sA self_type env fuel, + let e := typecheck_and_eval_seq i A B sA self_type env fuel in + Bool.Is_true (error.success e) -> + typecheck_and_eval_seq (optimizer.optimize i) A B sA self_type env fuel = e. + Proof. + intros ui A B sA self_type env fuel. + unfold typecheck_and_eval_seq. + intro Hsucc. + apply error.success_bind in Hsucc. + destruct Hsucc as ((tff, i), (Hret, Hsucc)). + rewrite Hret. + simpl. + unfold typer.type_check_instruction_seq in Hret. + apply error.bind_eq_return in Hret. + destruct Hret as (t, (Ht, Hret)). + apply untyper.type_untype_seq in Ht. + destruct t. + - subst ui. + unfold typer.instruction_seq_cast_range, typer.instruction_seq_cast in Hret. + rewrite untyper.stype_dec_same in Hret. + destruct (stype_dec B0 B); [|discriminate]. + simpl in Hret. + apply error.unreturn in Hret. + repeat mytac. + rewrite <- (untype_cleanup). + unfold typer.type_check_instruction_seq. + simpl in *. + rewrite untyper.untype_type_instruction_seq. + simpl. + unfold typer.instruction_seq_cast_range. + rewrite untyper.instruction_seq_cast_same. + simpl. + apply same_semantics_cleanup. + assumption. + - apply error.unreturn in Hret. + repeat mytac. + simpl in Hsucc. + apply eval_fail_seq in Hsucc. + contradiction. + Qed. + +End Semantics_Preservation. diff --git a/src/michocoq/typer.v b/src/michocoq/typer.v index 011f46883861a5d5d5f6bb63acfad5073db27a65..3cf3051909a966be1a81c2fb7590147b7b875537 100644 --- a/src/michocoq/typer.v +++ b/src/michocoq/typer.v @@ -1,8 +1,13 @@ -Require Import ZArith List Nat String. -Require Import syntax semantics. +Require Import ZArith List Nat Ascii String. +Require Import ListString.All. +Require Import Moment.All. +Require syntax. +Require Import syntax_type. Require Import untyped_syntax error. Import error.Notations. +Inductive type_mode := Readable | Optimized | Any. + Lemma andb_and a b : (a && b)%bool <-> a /\ b. Proof. @@ -11,12 +16,17 @@ Proof. - apply Bool.andb_prop_intro. Qed. -Module Typer(C : ContractContext). + Definition instruction := syntax.instruction. - Module syntax := Syntax C. - Import syntax. Import untyped_syntax. + Definition instruction_seq := syntax.instruction_seq. - Definition instruction := syntax.instruction. + Definition safe_opcode_cast {self_type} A A' B B' : + syntax.opcode (self_type := self_type) A B -> A = A' -> B = B' -> + syntax.opcode (self_type := self_type) A' B'. + Proof. + intros o [] []. + exact o. + Defined. Definition safe_instruction_cast {self_type tff} A A' B B' : instruction self_type tff A B -> A = A' -> B = B' -> instruction self_type tff A' B'. @@ -25,6 +35,13 @@ Module Typer(C : ContractContext). exact i. Defined. + Definition safe_instruction_seq_cast {self_type tff} A A' B B' : + instruction_seq self_type tff A B -> A = A' -> B = B' -> instruction_seq self_type tff A' B'. + Proof. + intros i [] []. + exact i. + Defined. + Record cast_error := Mk_cast_error { @@ -33,32 +50,52 @@ Module Typer(C : ContractContext). expected_input : Datatypes.list type; expected_output : Datatypes.list type; tff : Datatypes.bool; - self_type_ : Datatypes.option type; - i : instruction self_type_ tff input output; + self_type_ : syntax.self_info; + i : instruction_seq self_type_ tff input output; }. + Definition opcode_cast {self_type} A A' B B' o : M (syntax.opcode A' B') := + match stype_dec A A', stype_dec B B' with + | left HA, left HB => Return (safe_opcode_cast A A' B B' o HA HB) + | _, _ => + Failed _ (Typing cast_error + (Mk_cast_error A B A' B' Datatypes.false self_type + (syntax.instruction_wrap + (syntax.Instruction_opcode o)))) + end. + Definition instruction_cast {self_type tff} A A' B B' i : M (instruction self_type tff A' B') := match stype_dec A A', stype_dec B B' with | left HA, left HB => Return (safe_instruction_cast A A' B B' i HA HB) + | _, _ => Failed _ (Typing cast_error (Mk_cast_error A B A' B' tff _ (syntax.instruction_wrap i))) + end. + + Definition instruction_seq_cast {self_type tff} A A' B B' i : M (instruction_seq self_type tff A' B') := + match stype_dec A A', stype_dec B B' with + | left HA, left HB => Return (safe_instruction_seq_cast A A' B B' i HA HB) | _, _ => Failed _ (Typing cast_error (Mk_cast_error A B A' B' tff _ i)) end. Definition instruction_cast_range {self_type tff} A B B' (i : instruction self_type tff A B) : M (instruction self_type tff A B') := instruction_cast A A B B' i. + Definition instruction_seq_cast_range {self_type tff} A B B' (i : instruction_seq self_type tff A B) + : M (instruction_seq self_type tff A B') := instruction_seq_cast A A B B' i. + Definition instruction_cast_domain {self_type tff} A A' B (i : instruction self_type tff A B) : M (instruction self_type tff A' B) := instruction_cast A A' B B i. - Definition contract_cast (c : contract_constant) (a b : type) - (H : C.get_contract_type c = Some b) - (He : a = b) - : syntax.concrete_data (contract a) := - syntax.Contract_constant c (eq_trans H (f_equal Some (eq_sym He))). + Definition opcode_cast_domain self_type A A' B (o : @syntax.opcode self_type A B) + : M (@syntax.opcode self_type A' B) := opcode_cast A A' B B o. Inductive typer_result {self_type} A : Set := | Inferred_type B : instruction self_type false A B -> typer_result A | Any_type : (forall B, instruction self_type true A B) -> typer_result A. + Inductive typer_result_seq {self_type} A : Set := + | Inferred_type_seq B : instruction_seq self_type false A B -> typer_result_seq A + | Any_type_seq : (forall B, instruction_seq self_type true A B) -> typer_result_seq A. + Definition type_check_instruction {self_type} (type_instruction : forall (i : untyped_syntax.instruction) A, @@ -72,15 +109,28 @@ Module Typer(C : ContractContext). | Any_type _ i => Return (existT _ true (i B)) end. - Definition type_check_instruction_no_tail_fail {self_type} - (type_instruction : - forall (i : untyped_syntax.instruction) A, - M (typer_result A)) - i A B : M (instruction self_type Datatypes.false A B) := - let! r1 := type_instruction i A in + Definition type_check_instruction_seq {self_type} + (type_instruction_seq : + forall (i : untyped_syntax.instruction_seq) A, + M (typer_result_seq A)) + i A B : M {b : Datatypes.bool & instruction_seq self_type b A B} := + let! r1 := type_instruction_seq i A in + match r1 with + | Inferred_type_seq _ B' i => + let! i := instruction_seq_cast_range A B' B i in + Return (existT _ false i) + | Any_type_seq _ i => Return (existT _ true (i B)) + end. + + Definition type_check_instruction_seq_no_tail_fail {self_type} + (type_instruction_seq : + forall (i : untyped_syntax.instruction_seq) A, + M (typer_result_seq A)) + i A B : M (instruction_seq self_type Datatypes.false A B) := + let! r1 := type_instruction_seq i A in match r1 with - | Inferred_type _ B' i => instruction_cast_range A B' B i - | Any_type _ i => Failed _ (Typing _ tt) + | Inferred_type_seq _ B' i => instruction_seq_cast_range A B' B i + | Any_type_seq _ i => Failed _ (Typing _ tt) end. Definition assert_not_tail_fail {self_type} A (r : typer_result A) : @@ -98,41 +148,81 @@ Module Typer(C : ContractContext). let! r := type_instruction i A in assert_not_tail_fail A r. - Definition type_branches {self_type} - (type_instruction : - forall (i : untyped_syntax.instruction) A, - M (typer_result A)) - i1 i2 A1 A2 A - (IF_instr : forall B tffa tffb, - instruction self_type tffa A1 B -> - instruction self_type tffb A2 B -> - instruction self_type (tffa && tffb) A B) - : M (typer_result A) := - let! r1 := type_instruction i1 A1 in - let! r2 := type_instruction i2 A2 in + Definition assert_not_tail_fail_seq {self_type} A (r : typer_result_seq A) : + M {B & instruction_seq self_type Datatypes.false A B} := + match r with + | Inferred_type_seq _ B i => Return (existT _ B i) + | Any_type_seq _ _ => Failed _ (Typing _ tt) + end. + + Definition type_instruction_seq_no_tail_fail {self_type} + (type_instruction_seq : + forall (i : untyped_syntax.instruction_seq) A, + M (typer_result_seq A)) + i A : M {B & instruction_seq self_type Datatypes.false A B} := + let! r := type_instruction_seq i A in + assert_not_tail_fail_seq A r. + + Definition type_if_family (f : if_family) (t : type) : + M {A & {B & syntax.if_family A B t}} := + match f, t with + | IF_bool, Comparable_type bool => Return (existT _ _ (existT _ _ syntax.IF_bool)) + | IF_option, option a => Return (existT _ _ (existT _ _ (syntax.IF_option a))) + | IF_or, or a an b bn => Return (existT _ _ (existT _ _ (syntax.IF_or a an b bn))) + | IF_list, list a => Return (existT _ _ (existT _ _ (syntax.IF_list a))) + | _, _ => Failed _ (Typing _ "type_family"%string) + end. + + Definition type_branches {self_type} (f : if_family) (t : type) + (type_instruction_seq : + forall (i : untyped_syntax.instruction_seq) A, + M (typer_result_seq A)) + i1 i2 A + : M (typer_result (self_type := self_type) (t ::: A)) := + let! (existT _ B1 (existT _ B2 f)) := type_if_family f t in + let! r1 := type_instruction_seq i1 (B1 ++ A) in + let! r2 := type_instruction_seq i2 (B2 ++ A) in match r1, r2 with - | Inferred_type _ B1 i1, Inferred_type _ B2 i2 => - let! i2 := instruction_cast_range A2 B2 B1 i2 in + | Inferred_type_seq _ C1 i1, Inferred_type_seq _ C2 i2 => + let! i2 := instruction_seq_cast_range (B2 ++ A) C2 C1 i2 in Return (Inferred_type _ _ - (IF_instr B1 false false i1 i2)) - | Inferred_type _ B i1, Any_type _ i2 => - Return (Inferred_type _ _ (IF_instr B false true i1 (i2 B))) - | Any_type _ i1, Inferred_type _ B i2 => - Return (Inferred_type _ _ (IF_instr B true false (i1 B) i2)) - | Any_type _ i1, Any_type _ i2 => - Return (Any_type _ (fun B => - IF_instr B true true (i1 B) (i2 B))) + (syntax.IF_ f i1 i2)) + | Inferred_type_seq _ C i1, Any_type_seq _ i2 => + Return (Inferred_type _ _ (syntax.IF_ f i1 (i2 C))) + | Any_type_seq _ i1, Inferred_type_seq _ C i2 => + Return (Inferred_type _ _ (syntax.IF_ f (i1 C) i2)) + | Any_type_seq _ i1, Any_type_seq _ i2 => + Return (Any_type _ (fun C => + syntax.IF_ f (i1 C) (i2 C))) + end. + + Definition type_loop_family (f : loop_family) (t : type) : + M {A & {B & syntax.loop_family A B t}} := + match f, t with + | LOOP_bool, Comparable_type bool => Return (existT _ _ (existT _ _ syntax.LOOP_bool)) + | LOOP_or, or a an b bn => Return (existT _ _ (existT _ _ (syntax.LOOP_or a an b bn))) + | _, _ => Failed _ (Typing _ "type_family"%string) end. - Definition take_one (S : stack_type) : M (type * stack_type) := + Definition type_loop {self_type} (f : loop_family) (t : type) + (type_instruction_seq : + forall (i : untyped_syntax.instruction_seq) A, + M (typer_result_seq A)) + (i : untyped_syntax.instruction_seq) A + : M (typer_result (self_type := self_type) (t ::: A)) := + let! (existT _ B1 (existT _ B2 f)) := type_loop_family f t in + let! r := type_check_instruction_seq_no_tail_fail type_instruction_seq i (B1 ++ A) (t ::: A) in + Return (Inferred_type _ _ (syntax.LOOP_ f r)). + + Definition take_one (S : syntax.stack_type) : M (type * syntax.stack_type) := match S with | nil => Failed _ (Typing _ "take_one"%string) | cons a l => Return (a, l) end. - Fixpoint take_n (A : stack_type) n : M ({B | List.length B = n} * stack_type) := - match n as n return M ({B | List.length B = n} * stack_type) with + Fixpoint take_n (A : syntax.stack_type) n : M ({B | List.length B = n} * syntax.stack_type) := + match n as n return M ({B | List.length B = n} * syntax.stack_type) with | 0 => Return (exist (fun B => List.length B = 0) nil eq_refl, A) | S n => let! (a, A) := take_one A in @@ -159,17 +249,17 @@ Module Typer(C : ContractContext). repeat decide equality. Qed. - Definition type_check_dig {self_type} n (S:stack_type) : M (typer_result (self_type := self_type) S) := + Definition type_check_dig {self_type} n (S:syntax.stack_type) : M { B : syntax.stack_type & syntax.opcode S B} := let! (exist _ S1 H1, tS2) := take_n S n in let! (t, S2) := take_one tS2 in - let! i := instruction_cast_domain (S1 +++ t ::: S2) S _ (syntax.DIG n H1) in - Return (Inferred_type S (t ::: S1 +++ S2) i). + let! o := opcode_cast_domain self_type (S1 +++ t ::: S2) S _ (syntax.DIG n H1) in + Return (existT _ (t ::: S1 +++ S2) o). - Definition type_check_dug {self_type} n (S:stack_type) : M (typer_result (self_type := self_type) S) := + Definition type_check_dug {self_type} n (S:syntax.stack_type) : M { B : syntax.stack_type & syntax.opcode S B} := let! (t, S12) := take_one S in let! (exist _ S1 H1, S2) := take_n S12 n in - let! i := instruction_cast_domain (t ::: S1 +++ S2) S _ (syntax.DUG n H1) in - Return (Inferred_type S (S1 +++ t ::: S2) i). + let! o := opcode_cast_domain self_type (t ::: S1 +++ S2) S _ (syntax.DUG n H1) in + Return (existT _ (S1 +++ t ::: S2) o). Fixpoint as_comparable (a : type) : M comparable_type := match a with @@ -190,19 +280,268 @@ Module Typer(C : ContractContext). reflexivity. Qed. - Definition type_contract_data_aux c a tyopt := - match tyopt return C.get_contract_type c = tyopt -> error.M (syntax.concrete_data (contract a)) with - | Some b => - match type_dec a b with - | left He => fun H => Return (contract_cast c a b H He) - | right _ => fun _ => Failed _ (Typing _ ("ill-typed contract"%string, c, a, b)) - end - | None => fun _ => Failed _ (Typing _ ("contract not found"%string, c)) + Definition type_opcode {self_type} (o : opcode) A : M { B : syntax.stack_type & @syntax.opcode self_type A B} := + match o, A with + | APPLY, a :: lambda (pair a' b) c :: B => + let A := a :: lambda (pair a' b) c :: B in + let A' := a :: lambda (pair a b) c :: B in + (if is_packable a as b return is_packable a = b -> _ + then fun h => + let o := @syntax.APPLY _ _ _ _ _ (IT_eq_rev _ h) in + let! o := opcode_cast_domain self_type A' A _ o in + Return (existT _ _ o) + else fun _ => Failed _ (Typing _ "APPLY"%string)) eq_refl + | DUP, a :: A => + Return (existT _ _ syntax.DUP) + | SWAP, a :: b :: A => + Return (existT _ _ syntax.SWAP) + | UNIT, A => Return (existT _ _ syntax.UNIT) + | EQ, Comparable_type int :: A => + Return (existT _ _ syntax.EQ) + | NEQ, Comparable_type int :: A => + Return (existT _ _ syntax.NEQ) + | LT, Comparable_type int :: A => + Return (existT _ _ syntax.LT) + | GT, Comparable_type int :: A => + Return (existT _ _ syntax.GT) + | LE, Comparable_type int :: A => + Return (existT _ _ syntax.LE) + | GE, Comparable_type int :: A => + Return (existT _ _ syntax.GE) + | OR, Comparable_type bool :: Comparable_type bool :: A => + Return (existT _ _ (@syntax.OR _ _ syntax.bitwise_bool _)) + | OR, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.OR _ _ syntax.bitwise_nat _)) + | AND, Comparable_type bool :: Comparable_type bool :: A => + Return (existT _ _ (@syntax.AND _ _ _ syntax.and_bool _)) + | AND, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.AND _ _ _ syntax.and_nat _)) + | AND, Comparable_type int :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.AND _ _ _ syntax.and_int _)) + | XOR, Comparable_type bool :: Comparable_type bool :: A => + Return (existT _ _ (@syntax.XOR _ _ syntax.bitwise_bool _)) + | XOR, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.XOR _ _ syntax.bitwise_nat _)) + | NOT, Comparable_type bool :: A => + Return (existT _ _ (@syntax.NOT _ _ syntax.not_bool _)) + | NOT, Comparable_type nat :: A => + Return (existT _ _ (@syntax.NOT _ _ syntax.not_nat _)) + | NOT, Comparable_type int :: A => + Return (existT _ _ (@syntax.NOT _ _ syntax.not_int _)) + | NEG, Comparable_type nat :: A => + Return (existT _ _ (@syntax.NEG _ _ syntax.neg_nat _)) + | NEG, Comparable_type int :: A => + Return (existT _ _ (@syntax.NEG _ _ syntax.neg_int _)) + | ABS, Comparable_type int :: A => + Return (existT _ _ syntax.ABS) + | INT, Comparable_type nat :: A => + Return (existT _ _ syntax.INT) + | ISNAT, Comparable_type int :: A => + Return (existT _ _ syntax.ISNAT) + | ADD, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_nat_nat _)) + | ADD, Comparable_type nat :: Comparable_type int :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_nat_int _)) + | ADD, Comparable_type int :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_int_nat _)) + | ADD, Comparable_type int :: Comparable_type int :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_int_int _)) + | ADD, Comparable_type timestamp :: Comparable_type int :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_timestamp_int _)) + | ADD, Comparable_type int :: Comparable_type timestamp :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_int_timestamp _)) + | ADD, Comparable_type mutez :: Comparable_type mutez :: A => + Return (existT _ _ (@syntax.ADD _ _ _ syntax.add_tez_tez _)) + | SUB, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_nat_nat _)) + | SUB, Comparable_type nat :: Comparable_type int :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_nat_int _)) + | SUB, Comparable_type int :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_int_nat _)) + | SUB, Comparable_type int :: Comparable_type int :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_int_int _)) + | SUB, Comparable_type timestamp :: Comparable_type int :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_int _)) + | SUB, Comparable_type timestamp :: Comparable_type timestamp :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_timestamp _)) + | SUB, Comparable_type mutez :: Comparable_type mutez :: A => + Return (existT _ _ (@syntax.SUB _ _ _ syntax.sub_tez_tez _)) + | MUL, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_nat_nat _)) + | MUL, Comparable_type nat :: Comparable_type int :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_nat_int _)) + | MUL, Comparable_type int :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_int_nat _)) + | MUL, Comparable_type int :: Comparable_type int :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_int_int _)) + | MUL, Comparable_type mutez :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_tez_nat _)) + | MUL, Comparable_type nat :: Comparable_type mutez :: A => + Return (existT _ _ (@syntax.MUL _ _ _ syntax.mul_nat_tez _)) + | EDIV, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_nat _)) + | EDIV, Comparable_type nat :: Comparable_type int :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_int _)) + | EDIV, Comparable_type int :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_nat _)) + | EDIV, Comparable_type int :: Comparable_type int :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_int _)) + | EDIV, Comparable_type mutez :: Comparable_type nat :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_nat _)) + | EDIV, Comparable_type mutez :: Comparable_type mutez :: A => + Return (existT _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_tez _)) + | LSL, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ syntax.LSL) + | LSR, Comparable_type nat :: Comparable_type nat :: A => + Return (existT _ _ syntax.LSR) + | COMPARE, a :: a' :: B => + let A := a ::: a' ::: B in + let! a : comparable_type := as_comparable a in + let! a' : comparable_type := as_comparable a' in + let A' := a ::: a ::: B in + let! o := opcode_cast_domain self_type A' A (int ::: B) (syntax.COMPARE (a := a)) in + Return (existT _ _ o) + | CONCAT, Comparable_type string :: Comparable_type string :: B => + Return (existT _ _ (@syntax.CONCAT _ _ syntax.stringlike_string _)) + | CONCAT, Comparable_type bytes :: Comparable_type bytes :: B => + Return (existT _ _ (@syntax.CONCAT _ _ syntax.stringlike_bytes _)) + | CONCAT, list (Comparable_type string) :: B => + Return (existT _ _ (@syntax.CONCAT_list _ _ syntax.stringlike_string _)) + | CONCAT, list (Comparable_type bytes) :: B => + Return (existT _ _ (@syntax.CONCAT_list _ _ syntax.stringlike_bytes _)) + | SIZE, set a :: A => + Return (existT _ _ (@syntax.SIZE _ _ (syntax.size_set a) _)) + | SIZE, cons (list a) A => + Return (existT _ _ (@syntax.SIZE _ _ (syntax.size_list a) _)) + | SIZE, cons (map a b) A => + Return (existT _ _ (@syntax.SIZE _ _ (syntax.size_map a b) _)) + | SIZE, Comparable_type string :: A => + Return (existT _ _ (@syntax.SIZE _ _ syntax.size_string _)) + | SIZE, Comparable_type bytes :: A => + Return (existT _ _ (@syntax.SIZE _ _ syntax.size_bytes _)) + | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type string :: A => + Return (existT _ _ (@syntax.SLICE _ _ syntax.stringlike_string _)) + | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type bytes :: A => + Return (existT _ _ (@syntax.SLICE _ _ syntax.stringlike_bytes _)) + | PAIR, a :: b :: A => + Return (existT _ _ syntax.PAIR) + | CAR, pair a b :: A => + Return (existT _ _ syntax.CAR) + | CDR, pair a b :: A => + Return (existT _ _ syntax.CDR) + | EMPTY_SET c, A => + Return (existT _ _ (syntax.EMPTY_SET c)) + | MEM, elt' :: set elt :: B => + let A := elt' :: set elt :: B in + let A' := elt ::: set elt :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.MEM _ _ _ (syntax.mem_set elt) _) in + Return (existT _ _ o) + | MEM, kty' :: map kty vty :: B => + let A := kty' :: map kty vty :: B in + let A' := kty ::: map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.MEM _ _ _ (syntax.mem_map kty vty) _) in + Return (existT _ _ o) + | MEM, kty' :: big_map kty vty :: B => + let A := kty' :: big_map kty vty :: B in + let A' := kty ::: big_map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.MEM _ _ _ (syntax.mem_bigmap kty vty) _) in + Return (existT _ _ o) + | UPDATE, elt' :: Comparable_type bool :: set elt :: B => + let A := elt' ::: bool ::: set elt :: B in + let A' := elt ::: bool ::: set elt :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.UPDATE _ _ _ _ (syntax.update_set elt) _) in + Return (existT _ _ o) + | UPDATE, kty' :: option vty' :: map kty vty :: B => + let A := kty' ::: option vty' ::: map kty vty :: B in + let A' := kty ::: option vty ::: map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.UPDATE _ _ _ _ (syntax.update_map kty vty) _) in + Return (existT _ _ o) + | UPDATE, kty' :: option vty' :: big_map kty vty :: B => + let A := kty' ::: option vty' ::: big_map kty vty :: B in + let A' := kty ::: option vty ::: big_map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.UPDATE _ _ _ _ (syntax.update_bigmap kty vty) _) in + Return (existT _ _ o) + | EMPTY_MAP kty vty, A => + Return (existT _ _ (syntax.EMPTY_MAP kty vty)) + | EMPTY_BIG_MAP kty vty, A => + Return (existT _ _ (syntax.EMPTY_BIG_MAP kty vty)) + | GET, kty' :: map kty vty :: B => + let A := kty' :: map kty vty :: B in + let A' := kty ::: map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.GET _ _ _ (syntax.get_map kty vty) _) in + Return (existT _ _ o) + | GET, kty' :: big_map kty vty :: B => + let A := kty' :: big_map kty vty :: B in + let A' := kty ::: big_map kty vty :: B in + let! o := opcode_cast_domain + self_type A' A _ (@syntax.GET _ _ _ (syntax.get_bigmap kty vty) _) in + Return (existT _ _ o) + | SOME, a :: A => Return (existT _ _ syntax.SOME) + | NONE a, A => Return (existT _ _ (syntax.NONE a)) + | LEFT b, a :: A => Return (existT _ _ (syntax.LEFT b)) + | RIGHT a, b :: A => Return (existT _ _ (syntax.RIGHT a)) + | CONS, a' :: list a :: B => + let A := a' :: list a :: B in + let A' := a :: list a :: B in + let! o := opcode_cast_domain self_type A' A _ (syntax.CONS) in + Return (existT _ _ o) + | NIL a, A => Return (existT _ _ (syntax.NIL a)) + | TRANSFER_TOKENS, p1 :: Comparable_type mutez :: contract p2 :: B => + let A := p1 ::: mutez ::: contract p2 ::: B in + let A' := p1 ::: mutez ::: contract p1 ::: B in + let! o := opcode_cast_domain self_type A' A _ syntax.TRANSFER_TOKENS in + Return (existT _ _ o) + | SET_DELEGATE, option (Comparable_type key_hash) :: A => + Return (existT _ _ syntax.SET_DELEGATE) + | BALANCE, A => + Return (existT _ _ syntax.BALANCE) + | ADDRESS, contract _ :: A => + Return (existT _ _ syntax.ADDRESS) + | CONTRACT an ty, Comparable_type address :: A => + Return (existT _ _ (syntax.CONTRACT an ty)) + | SOURCE, A => + Return (existT _ _ syntax.SOURCE) + | SENDER, A => + Return (existT _ _ syntax.SENDER) + | AMOUNT, A => + Return (existT _ _ syntax.AMOUNT) + | IMPLICIT_ACCOUNT, Comparable_type key_hash :: A => + Return (existT _ _ syntax.IMPLICIT_ACCOUNT) + | NOW, A => + Return (existT _ _ syntax.NOW) + | PACK, a :: A => + Return (existT _ _ syntax.PACK) + | UNPACK ty, Comparable_type bytes :: A => + Return (existT _ _ (syntax.UNPACK ty)) + | HASH_KEY, key :: A => + Return (existT _ _ syntax.HASH_KEY) + | BLAKE2B, Comparable_type bytes :: A => + Return (existT _ _ syntax.BLAKE2B) + | SHA256, Comparable_type bytes :: A => + Return (existT _ _ syntax.SHA256) + | SHA512, Comparable_type bytes :: A => + Return (existT _ _ syntax.SHA512) + | CHECK_SIGNATURE, key :: signature :: Comparable_type bytes :: A => + Return (existT _ _ syntax.CHECK_SIGNATURE) + | DIG n, A => type_check_dig n _ + | DUG n, A => type_check_dug n _ + | DROP n, S12 => + let! (exist _ S1 H1, S2) := take_n S12 n in + let! o := opcode_cast_domain self_type (S1 +++ S2) S12 _ (syntax.DROP n H1) in + Return (existT _ _ o) + | CHAIN_ID, _ => + Return (existT _ _ syntax.CHAIN_ID) + | _, _ => Failed _ (Typing _ (instruction_opcode o, A)) end. - Definition type_contract_data c a := type_contract_data_aux c a _ eq_refl. - - Fixpoint type_data (d : concrete_data) {struct d} + Fixpoint type_data (tm : type_mode) (d : concrete_data) {struct d} : forall ty, M (syntax.concrete_data ty) := match d with | Int_constant z => @@ -214,8 +553,12 @@ Module Typer(C : ContractContext). else Failed _ (Typing _ ("Negative value cannot be typed in nat"%string, d)) | Comparable_type mutez => let! m := tez.of_Z z in - Return (syntax.Mutez_constant (Mk_mutez m)) - | Comparable_type timestamp => Return (syntax.Timestamp_constant z) + Return (syntax.Mutez_constant (syntax.Mk_mutez m)) + | Comparable_type timestamp => + match tm with + | Optimized | Any => Return (syntax.Timestamp_constant z) + | Readable => Failed _ (Typing _ ("Not readable"%string, (d, ty))) + end | _ => Failed _ (Typing _ (d, ty)) end | String_constant s => @@ -225,17 +568,60 @@ Module Typer(C : ContractContext). | signature => Return (syntax.Signature_constant s) | key => Return (syntax.Key_constant s) | Comparable_type key_hash => Return (syntax.Key_hash_constant s) - | contract a => - let c := Mk_contract s in - type_contract_data c a - | Comparable_type address => Return (syntax.Address_constant (syntax.Mk_address s)) - | chain_id => Return (syntax.Chain_id_constant (syntax.Mk_chain_id s)) + | Comparable_type address => + let fail := + Failed + _ + (Typing + _ + ("Address litterals should start by 'tz' or by 'KT1'"%string, + s)) + in + match s with + | String c1 (String c2 s) => + if ascii_dec c1 "t" then + if ascii_dec c2 "z" then + Return (syntax.Address_constant + (syntax.Implicit (syntax.Mk_key_hash s))) + else fail + else + match s with + | String c3 s => + if ascii_dec c1 "K" then + if ascii_dec c2 "T" then + if ascii_dec c3 "1" then + Return (syntax.Address_constant + (syntax.Originated + (syntax.Mk_smart_contract_address s))) + else + fail + else + fail + else fail + | _ => fail + end + | _ => fail + end + | Comparable_type timestamp => + match tm with + | Optimized => Failed _ (Typing _ ("Not optimized"%string, (d, ty))) + | Readable + | Any => + match Moment.Parse.rfc3339_non_strict (LString.s s) with + | Some (moment, nil) => + let z := Moment.to_epoch moment in + Return (syntax.Timestamp_constant z) + | _ => + Failed _ (Typing _ ("Cannot parse timestamp according to rfc3339"%string, s)) + end + end | _ => Failed _ (Typing _ (d, ty)) end | Bytes_constant s => fun ty => match ty with | Comparable_type bytes => Return (syntax.Bytes_constant s) + | chain_id => Return (syntax.Chain_id_constant (syntax.Mk_chain_id s)) | _ => Failed _ (Typing _ (d, ty)) end | Unit => @@ -260,32 +646,32 @@ Module Typer(C : ContractContext). fun ty => match ty with | pair a b => - let! x := type_data x a in - let! y := type_data y b in + let! x := type_data tm x a in + let! y := type_data tm y b in Return (syntax.Pair x y) | _ => Failed _ (Typing _ (d, ty)) end | Left x => fun ty => match ty with - | or a b => - let! x := type_data x a in - Return (syntax.Left x) + | or a an b bn => + let! x := type_data tm x a in + Return (syntax.Left x an bn) | _ => Failed _ (Typing _ (d, ty)) end | Right y => fun ty => match ty with - | or a b => - let! y := type_data y b in - Return (syntax.Right y) + | or a an b bn => + let! y := type_data tm y b in + Return (syntax.Right y an bn) | _ => Failed _ (Typing _ (d, ty)) end | Some_ x => fun ty => match ty with | option a => - let! x := type_data x a in + let! x := type_data tm x a in Return (syntax.Some_ x) | _ => Failed _ (Typing _ (d, ty)) end @@ -304,7 +690,7 @@ Module Typer(C : ContractContext). match l with | nil => Return nil | cons x l => - let! x := type_data x a in + let! x := type_data tm x a in let! l := type_data_list l in Return (cons x l) end @@ -316,7 +702,7 @@ Module Typer(C : ContractContext). match l with | nil => Return nil | cons x l => - let! x := type_data x a in + let! x := type_data tm x a in let! l := type_data_list l in Return (cons x l) end @@ -328,21 +714,35 @@ Module Typer(C : ContractContext). match l with | nil => Return nil | cons (Elt x y) l => - let! x := type_data x a in - let! y := type_data y b in + let! x := type_data tm x a in + let! y := type_data tm y b in let! l := type_data_list l in Return (cons (syntax.Elt _ _ x y) l) | _ => Failed _ (Typing _ (d, ty)) end ) l in Return (syntax.Concrete_map l) + | big_map a b => + let! l := + (fix type_data_list l := + match l with + | nil => Return nil + | cons (Elt x y) l => + let! x := type_data tm x a in + let! y := type_data tm y b in + let! l := type_data_list l in + Return (cons (syntax.Elt _ _ x y) l) + | _ => Failed _ (Typing _ (d, ty)) + end + ) l in + Return (syntax.Concrete_big_map l) | _ => Failed _ (Typing _ (d, ty)) end | Instruction i => fun ty => match ty with | lambda a b => - let! existT _ tff i := type_check_instruction type_instruction i (cons a nil) (cons b nil) in + let! existT _ tff i := type_check_instruction_seq (type_instruction_seq tm) i (cons a nil) (cons b nil) in Return (syntax.Instruction _ i) | _ => Failed _ (Typing _ (d, ty)) end @@ -350,345 +750,116 @@ Module Typer(C : ContractContext). end with - type_instruction {self_type} i A {struct i} : M (typer_result (self_type := self_type) A) := + type_instruction {self_type} tm i A {struct i} : M (typer_result (self_type := self_type) A) := match i, A with - | NOOP, A => Return (Inferred_type _ _ syntax.NOOP) - | FAILWITH, a :: A => Return (Any_type _ (fun B => syntax.FAILWITH)) - | SEQ i1 i2, A => - let! existT _ B i1 := type_instruction_no_tail_fail type_instruction i1 A in - let! r2 := type_instruction i2 B in - match r2 with - | Inferred_type _ C i2 => - Return (Inferred_type _ _ (syntax.SEQ i1 i2)) - | Any_type _ i2 => - Return (Any_type _ (fun C => syntax.SEQ i1 (i2 C))) + | Instruction_seq i, _ => + let! i := type_instruction_seq tm i A in + match i with + | Any_type_seq _ i => Return (Any_type _ (fun B => syntax.Instruction_seq (i B))) + | Inferred_type_seq _ _ i => Return (Inferred_type _ _ (syntax.Instruction_seq i)) end - | IF_ i1 i2, Comparable_type bool :: A => - type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_) - | IF_NONE i1 i2, option a :: A => - type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_NONE) - | IF_LEFT i1 i2, or a b :: A => - type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_LEFT) - | IF_CONS i1 i2, list a :: A => - type_branches type_instruction i1 i2 _ _ _ (fun B tffa tffb => syntax.IF_CONS) - | LOOP i, Comparable_type bool :: A => - let! i := type_check_instruction_no_tail_fail - type_instruction i A (bool ::: A) in - Return (Inferred_type _ _ (syntax.LOOP i)) - | LOOP_LEFT i, or a b :: A => - let! i := type_check_instruction_no_tail_fail - type_instruction i (a :: A) (or a b :: A) in - Return (Inferred_type _ _ (syntax.LOOP_LEFT i)) + | FAILWITH, a :: A => Return (Any_type _ (fun B => syntax.FAILWITH)) + | IF_ f i1 i2, t :: A => + type_branches f t (type_instruction_seq tm) i1 i2 A + | LOOP_ f i, t :: A => + type_loop f t (type_instruction_seq tm) i A | EXEC, a :: lambda a' b :: B => let A := a :: lambda a' b :: B in let A' := a :: lambda a b :: B in let! i := instruction_cast_domain A' A _ syntax.EXEC in Return (Inferred_type _ _ i) - | APPLY, a :: lambda (pair a' b) c :: B => - let A := a :: lambda (pair a' b) c :: B in - let A' := a :: lambda (pair a b) c :: B in - (if is_packable a as b return is_packable a = b -> _ - then fun i => - let! i := instruction_cast_domain A' A _ (@syntax.APPLY _ _ _ _ _ (IT_eq_rev _ i)) in - Return (Inferred_type _ _ i) - else fun _ => Failed _ (Typing _ "APPLY"%string)) eq_refl - | DUP, a :: A => - Return (Inferred_type _ _ syntax.DUP) - | SWAP, a :: b :: A => - Return (Inferred_type _ _ syntax.SWAP) | PUSH a v, A => - let! d := type_data v a in + let! d := type_data tm v a in Return (Inferred_type _ _ (syntax.PUSH a d)) - | UNIT, A => Return (Inferred_type _ _ syntax.UNIT) | LAMBDA a b i, A => let! existT _ tff i := - type_check_instruction type_instruction i (a :: nil) (b :: nil) in + type_check_instruction_seq (type_instruction_seq tm) i (a :: nil) (b :: nil) in Return (Inferred_type _ _ (syntax.LAMBDA a b i)) - | EQ, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.EQ) - | NEQ, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.NEQ) - | LT, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.LT) - | GT, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.GT) - | LE, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.LE) - | GE, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.GE) - | OR, Comparable_type bool :: Comparable_type bool :: A => - Return (Inferred_type _ _ (@syntax.OR _ _ syntax.bitwise_bool _)) - | OR, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.OR _ _ syntax.bitwise_nat _)) - | AND, Comparable_type bool :: Comparable_type bool :: A => - Return (Inferred_type _ _ (@syntax.AND _ _ syntax.bitwise_bool _)) - | AND, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.AND _ _ syntax.bitwise_nat _)) - | XOR, Comparable_type bool :: Comparable_type bool :: A => - Return (Inferred_type _ _ (@syntax.XOR _ _ syntax.bitwise_bool _)) - | XOR, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.XOR _ _ syntax.bitwise_nat _)) - | NOT, Comparable_type bool :: A => - Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_bool _)) - | NOT, Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_nat _)) - | NOT, Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.NOT _ _ syntax.not_int _)) - | NEG, Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.NEG _ _ syntax.neg_nat _)) - | NEG, Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.NEG _ _ syntax.neg_int _)) - | ABS, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.ABS) - | INT, Comparable_type nat :: A => - Return (Inferred_type _ _ syntax.INT) - | ISNAT, Comparable_type int :: A => - Return (Inferred_type _ _ syntax.ISNAT) - | ADD, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_nat_nat _)) - | ADD, Comparable_type nat :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_nat_int _)) - | ADD, Comparable_type int :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_nat _)) - | ADD, Comparable_type int :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_int _)) - | ADD, Comparable_type timestamp :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_timestamp_int _)) - | ADD, Comparable_type int :: Comparable_type timestamp :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_int_timestamp _)) - | ADD, Comparable_type mutez :: Comparable_type mutez :: A => - Return (Inferred_type _ _ (@syntax.ADD _ _ _ syntax.add_tez_tez _)) - | SUB, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_nat_nat _)) - | SUB, Comparable_type nat :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_nat_int _)) - | SUB, Comparable_type int :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_int_nat _)) - | SUB, Comparable_type int :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_int_int _)) - | SUB, Comparable_type timestamp :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_int _)) - | SUB, Comparable_type timestamp :: Comparable_type timestamp :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_timestamp_timestamp _)) - | SUB, Comparable_type mutez :: Comparable_type mutez :: A => - Return (Inferred_type _ _ (@syntax.SUB _ _ _ syntax.sub_tez_tez _)) - | MUL, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_nat _)) - | MUL, Comparable_type nat :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_int _)) - | MUL, Comparable_type int :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_int_nat _)) - | MUL, Comparable_type int :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_int_int _)) - | MUL, Comparable_type mutez :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_tez_nat _)) - | MUL, Comparable_type nat :: Comparable_type mutez :: A => - Return (Inferred_type _ _ (@syntax.MUL _ _ _ syntax.mul_nat_tez _)) - | EDIV, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_nat _)) - | EDIV, Comparable_type nat :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_nat_int _)) - | EDIV, Comparable_type int :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_nat _)) - | EDIV, Comparable_type int :: Comparable_type int :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_int_int _)) - | EDIV, Comparable_type mutez :: Comparable_type nat :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_nat _)) - | EDIV, Comparable_type mutez :: Comparable_type mutez :: A => - Return (Inferred_type _ _ (@syntax.EDIV _ _ _ syntax.ediv_tez_tez _)) - | LSL, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ syntax.LSL) - | LSR, Comparable_type nat :: Comparable_type nat :: A => - Return (Inferred_type _ _ syntax.LSR) - | COMPARE, a :: a' :: B => - let A := a ::: a' ::: B in - let! a : comparable_type := as_comparable a in - let! a' : comparable_type := as_comparable a' in - let A' := a ::: a ::: B in - let! i := instruction_cast_domain A' A (int ::: B) (syntax.COMPARE (a := a)) in - Return (Inferred_type _ _ i) - | CONCAT, Comparable_type string :: Comparable_type string :: B => - Return (Inferred_type _ _ (@syntax.CONCAT _ _ stringlike_string _)) - | CONCAT, Comparable_type bytes :: Comparable_type bytes :: B => - Return (Inferred_type _ _ (@syntax.CONCAT _ _ stringlike_bytes _)) - | CONCAT, list (Comparable_type string) :: B => - Return (Inferred_type _ _ (@syntax.CONCAT_list _ _ stringlike_string _)) - | CONCAT, list (Comparable_type bytes) :: B => - Return (Inferred_type _ _ (@syntax.CONCAT_list _ _ stringlike_bytes _)) - | SIZE, set a :: A => - Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_set a) _)) - | SIZE, cons (list a) A => - Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_list a) _)) - | SIZE, cons (map a b) A => - Return (Inferred_type _ _ (@syntax.SIZE _ _ (size_map a b) _)) - | SIZE, Comparable_type string :: A => - Return (Inferred_type _ _ (@syntax.SIZE _ _ size_string _)) - | SIZE, Comparable_type bytes :: A => - Return (Inferred_type _ _ (@syntax.SIZE _ _ size_bytes _)) - | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type string :: A => - Return (Inferred_type _ _ (@syntax.SLICE _ _ stringlike_string _)) - | SLICE, Comparable_type nat :: Comparable_type nat :: Comparable_type bytes :: A => - Return (Inferred_type _ _ (@syntax.SLICE _ _ stringlike_bytes _)) - | PAIR, a :: b :: A => - Return (Inferred_type _ _ syntax.PAIR) - | CAR, pair a b :: A => - Return (Inferred_type _ _ syntax.CAR) - | CDR, pair a b :: A => - Return (Inferred_type _ _ syntax.CDR) - | EMPTY_SET c, A => - Return (Inferred_type _ _ (syntax.EMPTY_SET c)) - | MEM, elt' :: set elt :: B => - let A := elt' :: set elt :: B in - let A' := elt ::: set elt :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.MEM _ _ _ (mem_set elt) _) in - Return (Inferred_type _ _ i) - | MEM, kty' :: map kty vty :: B => - let A := kty' :: map kty vty :: B in - let A' := kty ::: map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.MEM _ _ _ (mem_map kty vty) _) in - Return (Inferred_type _ _ i) - | MEM, kty' :: big_map kty vty :: B => - let A := kty' :: big_map kty vty :: B in - let A' := kty ::: big_map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.MEM _ _ _ (mem_bigmap kty vty) _) in - Return (Inferred_type _ _ i) - | UPDATE, elt' :: Comparable_type bool :: set elt :: B => - let A := elt' ::: bool ::: set elt :: B in - let A' := elt ::: bool ::: set elt :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.UPDATE _ _ _ _ (update_set elt) _) in - Return (Inferred_type _ _ i) - | UPDATE, kty' :: option vty' :: map kty vty :: B => - let A := kty' ::: option vty' ::: map kty vty :: B in - let A' := kty ::: option vty ::: map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.UPDATE _ _ _ _ (update_map kty vty) _) in - Return (Inferred_type _ _ i) - | UPDATE, kty' :: option vty' :: big_map kty vty :: B => - let A := kty' ::: option vty' ::: big_map kty vty :: B in - let A' := kty ::: option vty ::: big_map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.UPDATE _ _ _ _ (update_bigmap kty vty) _) in - Return (Inferred_type _ _ i) | ITER i, list a :: A => - let! i := type_check_instruction_no_tail_fail type_instruction i (a :: A) A in - Return (Inferred_type _ _ (syntax.ITER i)) + let! i := type_check_instruction_seq_no_tail_fail (type_instruction_seq tm) i (a :: A) A in + Return (Inferred_type _ _ (syntax.ITER (i := syntax.iter_list _) i)) | ITER i, set a :: A => - let! i := type_check_instruction_no_tail_fail type_instruction i (a ::: A) A in - Return (Inferred_type _ _ (syntax.ITER i)) + let! i := type_check_instruction_seq_no_tail_fail (type_instruction_seq tm) i (a ::: A) A in + Return (Inferred_type _ _ (syntax.ITER (i := syntax.iter_set _)i)) | ITER i, map kty vty :: A => - let! i := type_check_instruction_no_tail_fail type_instruction i (pair kty vty :: A) A in - Return (Inferred_type _ _ (syntax.ITER i)) - | EMPTY_MAP kty vty, A => - Return (Inferred_type _ _ (syntax.EMPTY_MAP kty vty)) - | EMPTY_BIG_MAP kty vty, A => - Return (Inferred_type _ _ (syntax.EMPTY_BIG_MAP kty vty)) - | GET, kty' :: map kty vty :: B => - let A := kty' :: map kty vty :: B in - let A' := kty ::: map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.GET _ _ _ (get_map kty vty) _) in - Return (Inferred_type _ _ i) - | GET, kty' :: big_map kty vty :: B => - let A := kty' :: big_map kty vty :: B in - let A' := kty ::: big_map kty vty :: B in - let! i := instruction_cast_domain - A' A _ (@syntax.GET _ _ _ (get_bigmap kty vty) _) in - Return (Inferred_type _ _ i) + let! i := type_check_instruction_seq_no_tail_fail (type_instruction_seq tm) i (pair kty vty :: A) A in + Return (Inferred_type _ _ (syntax.ITER (i := syntax.iter_map _ _) i)) | MAP i, list a :: A => - let! r := type_instruction_no_tail_fail type_instruction i (a :: A) in + let! r := type_instruction_seq_no_tail_fail (type_instruction_seq tm) i (a :: A) in match r with | existT _ (b :: A') i => - let! i := instruction_cast_range (a :: A) (b :: A') (b :: A) i in - Return (Inferred_type _ _ (syntax.MAP i)) + let! i := instruction_seq_cast_range (a :: A) (b :: A') (b :: A) i in + Return (Inferred_type _ _ (syntax.MAP (i := syntax.map_list _ _) i)) | _ => Failed _ (Typing _ tt) end | MAP i, map kty vty :: A => - let! r := type_instruction_no_tail_fail type_instruction i (pair kty vty ::: A) in + let! r := type_instruction_seq_no_tail_fail (type_instruction_seq tm) i (pair kty vty ::: A) in match r with | existT _ (b :: A') i => - let! i := instruction_cast_range (pair kty vty :: A) (b :: A') (b :: A) i in - Return (Inferred_type _ _ (syntax.MAP i)) + let! i := instruction_seq_cast_range (pair kty vty :: A) (b :: A') (b :: A) i in + Return (Inferred_type _ _ (syntax.MAP (i := syntax.map_map _ _ _) i)) | _ => Failed _ (Typing _ tt) end - | SOME, a :: A => Return (Inferred_type _ _ syntax.SOME) - | NONE a, A => Return (Inferred_type _ _ (syntax.NONE a)) - | LEFT b, a :: A => Return (Inferred_type _ _ (syntax.LEFT b)) - | RIGHT a, b :: A => Return (Inferred_type _ _ (syntax.RIGHT a)) - | CONS, a' :: list a :: B => - let A := a' :: list a :: B in - let A' := a :: list a :: B in - let! i := instruction_cast_domain A' A _ (syntax.CONS) in - Return (Inferred_type _ _ i) - | NIL a, A => Return (Inferred_type _ _ (syntax.NIL a)) - | CREATE_CONTRACT g p i, + | CREATE_CONTRACT g p an i, option (Comparable_type key_hash) :: Comparable_type mutez :: g2 :: B => let A := option key_hash ::: mutez ::: g2 :: B in let A' := option key_hash ::: mutez ::: g ::: B in let! existT _ tff i := - type_check_instruction (self_type := Some p) type_instruction i (pair p g :: nil) (pair (list operation) g :: nil) in - let! i := instruction_cast_domain A' A _ (syntax.CREATE_CONTRACT g p i) in + type_check_instruction_seq (self_type := (Some (p, an))) (type_instruction_seq tm) i (pair p g :: nil) (pair (list operation) g :: nil) in + let! i := instruction_cast_domain A' A _ (syntax.CREATE_CONTRACT g p an i) in Return (Inferred_type _ _ i) - | TRANSFER_TOKENS, p1 :: Comparable_type mutez :: contract p2 :: B => - let A := p1 ::: mutez ::: contract p2 ::: B in - let A' := p1 ::: mutez ::: contract p1 ::: B in - let! i := instruction_cast_domain A' A _ syntax.TRANSFER_TOKENS in - Return (Inferred_type _ _ i) - | SET_DELEGATE, option (Comparable_type key_hash) :: A => - Return (Inferred_type _ _ syntax.SET_DELEGATE) - | BALANCE, A => - Return (Inferred_type _ _ syntax.BALANCE) - | ADDRESS, contract _ :: A => - Return (Inferred_type _ _ syntax.ADDRESS) - | CONTRACT ty, Comparable_type address :: A => - Return (Inferred_type _ _ (syntax.CONTRACT ty)) - | SOURCE, A => - Return (Inferred_type _ _ syntax.SOURCE) - | SENDER, A => - Return (Inferred_type _ _ syntax.SENDER) - | SELF, A => + | SELF an, A => match self_type with - | Some sty => Return (Inferred_type _ _ syntax.SELF) + | Some (sty, san) => + let error := Typing _ "No such self entrypoint"%string in + let! H := syntax.isSome_maybe error (syntax.get_entrypoint_opt an sty san) in + Return (Inferred_type _ _ (syntax.SELF an H)) | None => Failed _ (Typing _ "SELF is not allowed inside lambdas"%string) end - | AMOUNT, A => - Return (Inferred_type _ _ syntax.AMOUNT) - | IMPLICIT_ACCOUNT, Comparable_type key_hash :: A => - Return (Inferred_type _ _ syntax.IMPLICIT_ACCOUNT) - | NOW, A => - Return (Inferred_type _ _ syntax.NOW) - | PACK, a :: A => - Return (Inferred_type _ _ syntax.PACK) - | UNPACK ty, Comparable_type bytes :: A => - Return (Inferred_type _ _ (syntax.UNPACK ty)) - | HASH_KEY, key :: A => - Return (Inferred_type _ _ syntax.HASH_KEY) - | BLAKE2B, Comparable_type bytes :: A => - Return (Inferred_type _ _ syntax.BLAKE2B) - | SHA256, Comparable_type bytes :: A => - Return (Inferred_type _ _ syntax.SHA256) - | SHA512, Comparable_type bytes :: A => - Return (Inferred_type _ _ syntax.SHA512) - | CHECK_SIGNATURE, key :: signature :: Comparable_type bytes :: A => - Return (Inferred_type _ _ syntax.CHECK_SIGNATURE) - | DIG n, A => type_check_dig n _ - | DUG n, A => type_check_dug n _ | DIP n i, S12 => let! (exist _ S1 H1, S2) := take_n S12 n in - let! existT _ B i := type_instruction_no_tail_fail type_instruction i S2 in + let! existT _ B i := type_instruction_seq_no_tail_fail (type_instruction_seq tm) i S2 in let! i := instruction_cast_domain (S1 +++ S2) S12 _ (syntax.DIP n H1 i) in Return (Inferred_type S12 (S1 +++ B) i) - | DROP n, S12 => - let! (exist _ S1 H1, S2) := take_n S12 n in - let! i := instruction_cast_domain (S1 +++ S2) S12 _ (syntax.DROP n H1) in - Return (Inferred_type S12 S2 i) - | CHAIN_ID, _ => - Return (Inferred_type _ _ syntax.CHAIN_ID) + | instruction_opcode o, A => + let! (existT _ B o) := type_opcode o A in + Return (Inferred_type A B (syntax.Instruction_opcode o)) | _, _ => Failed _ (Typing _ (i, A)) + end + with + type_instruction_seq {self_type} tm i A {struct i} : M (typer_result_seq (self_type := self_type) A) := + match i, A with + | NOOP, A => Return (Inferred_type_seq _ _ syntax.NOOP) + | SEQ i1 i2, A => + let! r1 := type_instruction tm i1 A in + match r1, i2 with + | Inferred_type _ B i1, i2 => + let! r2 := type_instruction_seq tm i2 B in + match r2 with + | Inferred_type_seq _ C i2 => + Return (Inferred_type_seq _ _ (syntax.SEQ i1 i2)) + | Any_type_seq _ i2 => + Return (Any_type_seq _ (fun C => syntax.SEQ i1 (i2 C))) + end + | Any_type _ i1, NOOP => + Return (Any_type_seq _ (fun C => syntax.Tail_fail (i1 C))) + | Any_type _ _, _ => + Failed _ (Typing _ + "FAILWITH instruction can only appear at the tail of application sequences"%string) + end + end. + + Definition extract_stack_type : Datatypes.list (type * concrete_data) -> Datatypes.list type := + List.map (fun c => fst c). + + Fixpoint type_stack (s : Datatypes.list (type * concrete_data)) : + M (syntax.typed_concrete_stack (extract_stack_type s)) := + match s with + | nil => Return tt + | cons (ty, x) s => + let! x := type_data Any x ty in + let! s := type_stack s in + Return (x, s) end. -End Typer. diff --git a/src/michocoq/untyped_syntax.v b/src/michocoq/untyped_syntax.v index 49d6de6c13dcdd0e1f0d9e41f5cf25be0293c56a..105ce7b549e54df7594a5384775f0ac0137fa90d 100644 --- a/src/michocoq/untyped_syntax.v +++ b/src/michocoq/untyped_syntax.v @@ -1,90 +1,95 @@ Require syntax. Require Import ZArith String. Require Import syntax_type. +Require decidable_types. +Inductive opcode : Set := +| APPLY : opcode +| DUP : opcode +| SWAP : opcode +| UNIT : opcode +| EQ : opcode +| NEQ : opcode +| LT : opcode +| GT : opcode +| LE : opcode +| GE : opcode +| OR : opcode +| AND : opcode +| XOR : opcode +| NOT : opcode +| NEG : opcode +| ABS : opcode +| INT : opcode +| ISNAT : opcode +| ADD : opcode +| SUB : opcode +| MUL : opcode +| EDIV : opcode +| LSL : opcode +| LSR : opcode +| COMPARE : opcode +| CONCAT : opcode +| SIZE : opcode +| SLICE : opcode +| PAIR : opcode +| CAR : opcode +| CDR : opcode +| EMPTY_SET : comparable_type -> opcode +| MEM : opcode +| UPDATE : opcode +| EMPTY_MAP : comparable_type -> type -> opcode +| EMPTY_BIG_MAP : comparable_type -> type -> opcode +| GET : opcode +| SOME : opcode +| NONE : type -> opcode +| LEFT : type -> opcode +| RIGHT : type -> opcode +| CONS : opcode +| NIL : type -> opcode +| TRANSFER_TOKENS : opcode +| SET_DELEGATE : opcode +| BALANCE : opcode +| ADDRESS : opcode +| CONTRACT : annot_o -> type -> opcode +| SOURCE : opcode +| SENDER : opcode +| AMOUNT : opcode +| IMPLICIT_ACCOUNT : opcode +| NOW : opcode +| PACK : opcode +| UNPACK : type -> opcode +| HASH_KEY : opcode +| BLAKE2B : opcode +| SHA256 : opcode +| SHA512 : opcode +| CHECK_SIGNATURE : opcode +| DIG : Datatypes.nat -> opcode +| DUG : Datatypes.nat -> opcode +| DROP : Datatypes.nat -> opcode +| CHAIN_ID : opcode. + +Inductive if_family : Set := IF_bool | IF_or | IF_option | IF_list. + +Inductive loop_family : Set := LOOP_bool | LOOP_or. Inductive instruction : Set := -| NOOP : instruction +| Instruction_seq : instruction_seq -> instruction | FAILWITH : instruction -| SEQ : instruction -> instruction -> instruction -| IF_ : instruction -> instruction -> instruction -| LOOP : instruction -> instruction -| LOOP_LEFT : instruction -> instruction -| EXEC : instruction -| APPLY : instruction -| DUP : instruction -| SWAP : instruction +| IF_ : if_family -> instruction_seq -> instruction_seq -> instruction +| LOOP_ : loop_family -> instruction_seq -> instruction | PUSH : type -> concrete_data -> instruction -| UNIT : instruction -| LAMBDA : type -> type -> instruction -> instruction -| EQ : instruction -| NEQ : instruction -| LT : instruction -| GT : instruction -| LE : instruction -| GE : instruction -| OR : instruction -| AND : instruction -| XOR : instruction -| NOT : instruction -| NEG : instruction -| ABS : instruction -| INT : instruction -| ISNAT : instruction -| ADD : instruction -| SUB : instruction -| MUL : instruction -| EDIV : instruction -| LSL : instruction -| LSR : instruction -| COMPARE : instruction -| CONCAT : instruction -| SIZE : instruction -| SLICE : instruction -| PAIR : instruction -| CAR : instruction -| CDR : instruction -| EMPTY_SET : comparable_type -> instruction -| MEM : instruction -| UPDATE : instruction -| ITER : instruction -> instruction -| EMPTY_MAP : comparable_type -> type -> instruction -| EMPTY_BIG_MAP : comparable_type -> type -> instruction -| GET : instruction -| MAP : instruction -> instruction -| SOME : instruction -| NONE : type -> instruction -| IF_NONE : instruction -> instruction -> instruction -| LEFT : type -> instruction -| RIGHT : type -> instruction -| IF_LEFT : instruction -> instruction -> instruction -| CONS : instruction -| NIL : type -> instruction -| IF_CONS : instruction -> instruction -> instruction -| CREATE_CONTRACT : type -> type -> instruction -> instruction -| TRANSFER_TOKENS : instruction -| SET_DELEGATE : instruction -| BALANCE : instruction -| ADDRESS : instruction -| CONTRACT : type -> instruction -| SOURCE : instruction -| SENDER : instruction -| SELF : instruction -| AMOUNT : instruction -| IMPLICIT_ACCOUNT : instruction -| NOW : instruction -| PACK : instruction -| UNPACK : type -> instruction -| HASH_KEY : instruction -| BLAKE2B : instruction -| SHA256 : instruction -| SHA512 : instruction -| CHECK_SIGNATURE : instruction -| DIG : Datatypes.nat -> instruction -| DUG : Datatypes.nat -> instruction -| DIP : Datatypes.nat -> instruction -> instruction -| DROP : Datatypes.nat -> instruction -| CHAIN_ID : instruction +| LAMBDA : type -> type -> instruction_seq -> instruction +| ITER : instruction_seq -> instruction +| MAP : instruction_seq -> instruction +| CREATE_CONTRACT : type -> type -> annot_o -> instruction_seq -> instruction +| DIP : Datatypes.nat -> instruction_seq -> instruction +| SELF : annot_o -> instruction +| EXEC : instruction +| instruction_opcode : opcode -> instruction +with instruction_seq : Set := +| NOOP : instruction_seq +| SEQ : instruction -> instruction_seq -> instruction_seq with concrete_data : Set := | Int_constant : Z -> concrete_data @@ -100,10 +105,92 @@ concrete_data : Set := | None_ : concrete_data | Elt : concrete_data -> concrete_data -> concrete_data | Concrete_seq : Datatypes.list concrete_data -> concrete_data -| Instruction : instruction -> concrete_data. +| Instruction : instruction_seq -> concrete_data. + + +Coercion instruction_opcode : opcode >-> instruction. + +Notation "'IF'" := (IF_ IF_bool). +Notation "'IF_LEFT'" := (IF_ IF_or). +Notation "'IF_NONE'" := (IF_ IF_option). +Notation "'IF_CONS'" := (IF_ IF_list). +Notation "'LOOP'" := (LOOP_ LOOP_bool). +Notation "'LOOP_LEFT'" := (LOOP_ LOOP_or). + +Fixpoint instruction_app i1 i2 := + match i1 with + | NOOP => i2 + | SEQ i11 i12 => SEQ i11 (instruction_app i12 i2) + end. (* Some macros *) Definition UNPAIR : instruction := - SEQ DUP (SEQ CAR (DIP 1 CDR)). + Instruction_seq (SEQ DUP (SEQ CAR (SEQ (DIP 1 (SEQ CDR NOOP)) NOOP))). Definition UNPAPAIR : instruction := - SEQ UNPAIR (DIP 1 UNPAIR). + Instruction_seq (SEQ UNPAIR (SEQ (DIP 1 (SEQ UNPAIR NOOP)) NOOP)). + +Lemma opcode_dec (o1 o2 : opcode) : {o1 = o2} + {o1 <> o2}. +Proof. + destruct o1; destruct o2; try (right; discriminate); try (left; reflexivity); + try (case (type_dec t t0); intuition congruence); + try (case (comparable_type_dec c c0); intuition congruence). + - (* EMPTY_MAP *) + case (comparable_type_dec c c0); case (type_dec t t0); intuition congruence. + - (* EMPTY_BIG_MAP *) + case (comparable_type_dec c c0); case (type_dec t t0); intuition congruence. + - (* CONTRACT *) + case (type_dec t t0); case (decidable_types.option_dec string_dec a a0); + intuition congruence. + - (* DIG *) + case (decidable_types.nat_dec n n0); intuition congruence. + - (* DUG *) + case (decidable_types.nat_dec n n0); intuition congruence. + - (* DROP *) + case (decidable_types.nat_dec n n0); intuition congruence. +Defined. + +Fixpoint instruction_dec (i1 i2 : instruction) : { i1 = i2 } + { i1 <> i2 } +with instruction_seq_dec (i1 i2 : instruction_seq) : { i1 = i2 } + { i1 <> i2 } +with concrete_data_dec (d1 d2 : concrete_data) : {d1 = d2} + {d1 <> d2}. +Proof. + - (* instruction_dec *) + destruct i1; destruct i2; try (right; discriminate); try (left; reflexivity); + try (case (instruction_seq_dec i i0); intuition congruence); + try (case (instruction_seq_dec i1_1 i2_1); case (instruction_seq_dec i1_2 i2_2); intuition congruence). + + (* IF_ *) + destruct i; destruct i2; try (right; discriminate); + case (instruction_seq_dec i0 i3); case (instruction_seq_dec i1 i4); intuition congruence. + + (* LOOP_ *) + destruct l; destruct l0; try (right; discriminate); + case (instruction_seq_dec i i0); intuition congruence. + + (* PUSH *) + case (type_dec t t0); case (concrete_data_dec c c0); intuition congruence. + + (* LAMBDA *) + case (type_dec t t1); case (type_dec t0 t2); case (instruction_seq_dec i i0); intuition congruence. + + (* CREATE_CONTRACT *) + case (type_dec t t1); case (type_dec t0 t2); case (decidable_types.option_dec string_dec a a0); + case (instruction_seq_dec i i0); intuition congruence. + + (* DIP *) + case (decidable_types.nat_dec n n0); case (instruction_seq_dec i i0); intuition congruence. + + (* SELF *) + case (decidable_types.option_dec string_dec a a0); intuition congruence. + + (* opcodes *) + case (opcode_dec o o0); intuition congruence. + - destruct i1; destruct i2; try (right; discriminate). + + intuition. + + case (instruction_dec i i0); case (instruction_seq_dec i1 i2); intuition congruence. + - (* concrete_data_dec *) + destruct d1; destruct d2; try (right; discriminate); + try (left; reflexivity); + try (case (concrete_data_dec d1 d2); intuition congruence); + try (case (concrete_data_dec d1_1 d2_1); case (concrete_data_dec d1_2 d2_2); + intuition congruence). + + (* Int *) + case (decidable_types.Z_dec z z0); intuition congruence. + + (* String *) + case (string_dec s s0); intuition congruence. + + (* Bytes *) + case (string_dec s s0); intuition congruence. + + case (decidable_types.list_dec concrete_data_dec l l0); intuition congruence. + + case (instruction_seq_dec i i0); intuition congruence. +Defined. diff --git a/src/michocoq/untyper.v b/src/michocoq/untyper.v index c9bf187b3fd0d19f5f2c9667c6fdbfe9656a02a0..a003958a9c103d8bffcb22ed8bc06d12e9e1e246 100644 --- a/src/michocoq/untyper.v +++ b/src/michocoq/untyper.v @@ -1,68 +1,24 @@ Require Import ZArith List. Require Import syntax. +Require Import typer. Require Import untyped_syntax error. -Require typer. Require Eqdep_dec. Import error.Notations. +Require Import Lia. (* Not really needed but eases reading of proof states. *) Require Import String. +Require Import Ascii. -Module Untyper(C : ContractContext). +Inductive untype_mode := untype_Readable | untype_Optimized. - Module syntax := Syntax C. - Module typer := typer.Typer C. - Import typer. Import syntax. Import untyped_syntax. - - - Fixpoint untype_data {a} (d : syntax.concrete_data a) : concrete_data := - match d with - | syntax.Int_constant z => Int_constant z - | syntax.Nat_constant n => Int_constant (Z.of_N n) - | syntax.String_constant s => String_constant s - | syntax.Mutez_constant (Mk_mutez m) => Int_constant (tez.to_Z m) - | syntax.Bytes_constant s => Bytes_constant s - | syntax.Timestamp_constant t => Int_constant t - | syntax.Signature_constant s => String_constant s - | syntax.Key_constant s => String_constant s - | syntax.Key_hash_constant s => String_constant s - | syntax.Contract_constant (Mk_contract c) _ => String_constant c - | syntax.Address_constant (Mk_address c) => String_constant c - | syntax.Unit => Unit - | syntax.True_ => True_ - | syntax.False_ => False_ - | syntax.Pair x y => Pair (untype_data x) (untype_data y) - | syntax.Left x => Left (untype_data x) - | syntax.Right y => Right (untype_data y) - | syntax.Some_ x => Some_ (untype_data x) - | syntax.None_ => None_ - | syntax.Concrete_list l => Concrete_seq (List.map (fun x => untype_data x) l) - | syntax.Concrete_set l => Concrete_seq (List.map (fun x => untype_data x) l) - | syntax.Concrete_map l => - Concrete_seq (List.map - (fun '(syntax.Elt _ _ x y) => Elt (untype_data x) (untype_data y)) - l) - | syntax.Instruction _ i => Instruction (untype_instruction i) - | syntax.Chain_id_constant (Mk_chain_id c) => String_constant c - end - with - untype_instruction {self_type tff0 A B} (i : syntax.instruction self_type tff0 A B) : instruction := - match i with - | syntax.NOOP => NOOP - | syntax.FAILWITH => FAILWITH - | syntax.SEQ i1 i2 => SEQ (untype_instruction i1) (untype_instruction i2) - | syntax.IF_ i1 i2 => IF_ (untype_instruction i1) (untype_instruction i2) - | syntax.LOOP i => LOOP (untype_instruction i) - | syntax.LOOP_LEFT i => LOOP_LEFT (untype_instruction i) - | syntax.DIP n _ i => DIP n (untype_instruction i) - | syntax.EXEC => EXEC + Definition untype_opcode {self_type A B} (o : @syntax.opcode self_type A B) : opcode := + match o with | syntax.APPLY => APPLY | syntax.DROP n _ => DROP n | syntax.DUP => DUP | syntax.SWAP => SWAP - | syntax.PUSH a x => PUSH a (untype_data x) | syntax.UNIT => UNIT - | syntax.LAMBDA a b i => LAMBDA a b (untype_instruction i) | syntax.EQ => EQ | syntax.NEQ => NEQ | syntax.LT => LT @@ -94,29 +50,22 @@ Module Untyper(C : ContractContext). | syntax.EMPTY_SET a => EMPTY_SET a | syntax.MEM => MEM | syntax.UPDATE => UPDATE - | syntax.ITER i => ITER (untype_instruction i) | syntax.EMPTY_MAP kty vty => EMPTY_MAP kty vty | syntax.EMPTY_BIG_MAP kty vty => EMPTY_BIG_MAP kty vty | syntax.GET => GET - | syntax.MAP i => MAP (untype_instruction i) | syntax.SOME => SOME | syntax.NONE a => NONE a - | syntax.IF_NONE i1 i2 => IF_NONE (untype_instruction i1) (untype_instruction i2) | syntax.LEFT b => LEFT b | syntax.RIGHT a => RIGHT a - | syntax.IF_LEFT i1 i2 => IF_LEFT (untype_instruction i1) (untype_instruction i2) | syntax.CONS => CONS | syntax.NIL a => NIL a - | syntax.IF_CONS i1 i2 => IF_CONS (untype_instruction i1) (untype_instruction i2) - | syntax.CREATE_CONTRACT g p i => CREATE_CONTRACT g p (untype_instruction i) | syntax.TRANSFER_TOKENS => TRANSFER_TOKENS | syntax.SET_DELEGATE => SET_DELEGATE | syntax.BALANCE => BALANCE | syntax.ADDRESS => ADDRESS - | syntax.CONTRACT a => CONTRACT a + | syntax.CONTRACT an a => CONTRACT an a | syntax.SOURCE => SOURCE | syntax.SENDER => SENDER - | syntax.SELF => SELF | syntax.AMOUNT => AMOUNT | syntax.IMPLICIT_ACCOUNT => IMPLICIT_ACCOUNT | syntax.NOW => NOW @@ -132,6 +81,93 @@ Module Untyper(C : ContractContext). | syntax.CHAIN_ID => CHAIN_ID end. + Definition untype_if_family {A B t} (f : syntax.if_family A B t) : if_family := + match f with + | syntax.IF_bool => IF_bool + | syntax.IF_or _ _ _ _ => IF_or + | syntax.IF_option _ => IF_option + | syntax.IF_list _ => IF_list + end. + + Definition untype_loop_family {A B t} (f : syntax.loop_family A B t) : loop_family := + match f with + | syntax.LOOP_bool => LOOP_bool + | syntax.LOOP_or _ _ _ _ => LOOP_or + end. + + Fixpoint untype_data {a} (um : untype_mode) (d : syntax.concrete_data a) : concrete_data := + match d with + | syntax.Int_constant z => Int_constant z + | syntax.Nat_constant n => Int_constant (Z.of_N n) + | syntax.String_constant s => String_constant s + | syntax.Mutez_constant (Mk_mutez m) => Int_constant (tez.to_Z m) + | syntax.Bytes_constant s => Bytes_constant s + | syntax.Timestamp_constant t => + match um with + | untype_Readable => + String_constant + (All.LString.to_string + (Moment.Print.rfc3339 + (Moment.of_epoch t))) + | untype_Optimized => + Int_constant t + end + | syntax.Signature_constant s => String_constant s + | syntax.Key_constant s => String_constant s + | syntax.Key_hash_constant s => String_constant s + | syntax.Address_constant c => + match c with + | syntax.Implicit (syntax.Mk_key_hash s) => + String_constant (String "t" (String "z" s)) + | syntax.Originated (syntax.Mk_smart_contract_address s) => + String_constant (String "K" (String "T" (String "1" s))) + end + | syntax.Unit => Unit + | syntax.True_ => True_ + | syntax.False_ => False_ + | syntax.Pair x y => Pair (untype_data um x) (untype_data um y) + | syntax.Left x _ _ => Left (untype_data um x) + | syntax.Right y _ _ => Right (untype_data um y) + | syntax.Some_ x => Some_ (untype_data um x) + | syntax.None_ => None_ + | syntax.Concrete_list l => Concrete_seq (List.map (untype_data um) l) + | syntax.Concrete_set l => Concrete_seq (List.map (untype_data um) l) + | syntax.Concrete_map l => + Concrete_seq (List.map + (fun '(syntax.Elt _ _ x y) => Elt (untype_data um x) (untype_data um y)) + l) + | syntax.Concrete_big_map l => + Concrete_seq (List.map + (fun '(syntax.Elt _ _ x y) => Elt (untype_data um x) (untype_data um y)) + l) + | syntax.Instruction _ i => Instruction (untype_instruction_seq um i) + | syntax.Chain_id_constant (Mk_chain_id c) => Bytes_constant c + end + with + untype_instruction {self_type tff0 A B} (um : untype_mode) (i : syntax.instruction self_type tff0 A B) : instruction := + match i with + | syntax.Instruction_seq i => + Instruction_seq (untype_instruction_seq um i) + | syntax.FAILWITH => FAILWITH + | syntax.IF_ f i1 i2 => IF_ (untype_if_family f) (untype_instruction_seq um i1) (untype_instruction_seq um i2) + | syntax.LOOP_ f i => LOOP_ (untype_loop_family f) (untype_instruction_seq um i) + | syntax.DIP n _ i => DIP n (untype_instruction_seq um i) + | syntax.EXEC => EXEC + | syntax.PUSH a x => PUSH a (untype_data um x) + | syntax.LAMBDA a b i => LAMBDA a b (untype_instruction_seq um i) + | syntax.ITER i => ITER (untype_instruction_seq um i) + | syntax.MAP i => MAP (untype_instruction_seq um i) + | syntax.CREATE_CONTRACT g p an i => CREATE_CONTRACT g p an (untype_instruction_seq um i) + | syntax.SELF an _ => SELF an + | syntax.Instruction_opcode o => instruction_opcode (untype_opcode o) + end + with untype_instruction_seq {self_type tff0 A B} (um : untype_mode) (i : syntax.instruction_seq self_type tff0 A B) : instruction_seq := + match i with + | syntax.NOOP => NOOP + | syntax.SEQ i1 i2 => SEQ (untype_instruction um i1) (untype_instruction_seq um i2) + | syntax.Tail_fail i => SEQ (untype_instruction um i) NOOP + end. + Lemma stype_dec_same A : stype_dec A A = left eq_refl. Proof. destruct (stype_dec A A) as [e | n]. @@ -155,118 +191,6 @@ Module Untyper(C : ContractContext). try (right; intro contra; discriminate contra). Qed. - Fixpoint tail_fail_induction self_type A B (i : syntax.instruction self_type true A B) - (P : forall self_type A B, syntax.instruction self_type true A B -> Type) - (HFAILWITH : forall st a A B, P st (a ::: A) B syntax.FAILWITH) - (HSEQ : forall st A B C i1 i2, - P st B C i2 -> - P st A C (i1;; i2)) - (HIF : forall st A B i1 i2, - P st A B i1 -> - P st A B i2 -> - P st (bool ::: A) B (syntax.IF_ i1 i2)) - (HIF_NONE : forall st a A B i1 i2, - P st A B i1 -> - P st (a ::: A) B i2 -> - P st (option a ::: A) B (syntax.IF_NONE i1 i2)) - (HIF_LEFT : forall st a b A B i1 i2, - P st (a ::: A) B i1 -> - P st (b ::: A) B i2 -> - P st (or a b ::: A) B (syntax.IF_LEFT i1 i2)) - (HIF_CONS : forall st a A B i1 i2, - P st (a ::: list a ::: A) B i1 -> - P st A B i2 -> - P st (list a ::: A) B (syntax.IF_CONS i1 i2)) - : P self_type A B i := - let P' st b A B : syntax.instruction st b A B -> Type := - if b return syntax.instruction st b A B -> Type - then P st A B - else fun i => True - in - match i as i0 in syntax.instruction st b A B return P' st b A B i0 - with - | syntax.FAILWITH => HFAILWITH _ _ _ _ - | @syntax.SEQ _ A B C tff i1 i2 => - (if tff return - forall i2 : syntax.instruction _ tff B C, - P' _ tff A C (syntax.SEQ i1 i2) - then - fun i2 => - HSEQ _ _ _ _ i1 i2 - (tail_fail_induction _ B C i2 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - else fun i2 => I) - i2 - | @syntax.IF_ _ A B tffa tffb i1 i2 => - (if tffa as tffa return - forall i1, P' _ (tffa && tffb)%bool _ _ (syntax.IF_ i1 i2) - then - fun i1 => - (if tffb return - forall i2, - P' _ tffb _ _ (syntax.IF_ i1 i2) - then - fun i2 => - HIF _ _ _ i1 i2 - (tail_fail_induction _ _ _ i1 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - (tail_fail_induction _ _ _ i2 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - else - fun _ => I) i2 - else - fun _ => I) i1 - | @syntax.IF_NONE _ a A B tffa tffb i1 i2 => - (if tffa as tffa return - forall i1, P' _ (tffa && tffb)%bool _ _ (syntax.IF_NONE i1 i2) - then - fun i1 => - (if tffb return - forall i2, - P' _ tffb _ _ (syntax.IF_NONE i1 i2) - then - fun i2 => - HIF_NONE _ _ _ _ i1 i2 - (tail_fail_induction _ _ _ i1 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - (tail_fail_induction _ _ _ i2 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - else - fun _ => I) i2 - else - fun _ => I) i1 - | @syntax.IF_LEFT _ a b A B tffa tffb i1 i2 => - (if tffa as tffa return - forall i1, P' _ (tffa && tffb)%bool _ _ (syntax.IF_LEFT i1 i2) - then - fun i1 => - (if tffb return - forall i2, - P' _ tffb _ _ (syntax.IF_LEFT i1 i2) - then - fun i2 => - HIF_LEFT _ _ _ _ _ i1 i2 - (tail_fail_induction _ _ _ i1 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - (tail_fail_induction _ _ _ i2 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - else - fun _ => I) i2 - else - fun _ => I) i1 - | @syntax.IF_CONS _ a A B tffa tffb i1 i2 => - (if tffa as tffa return - forall i1, P' _ (tffa && tffb)%bool _ _ (syntax.IF_CONS i1 i2) - then - fun i1 => - (if tffb return - forall i2, - P' _ tffb _ _ (syntax.IF_CONS i1 i2) - then - fun i2 => - HIF_CONS _ _ _ _ i1 i2 - (tail_fail_induction _ _ _ i1 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - (tail_fail_induction _ _ _ i2 P HFAILWITH HSEQ HIF HIF_NONE HIF_LEFT HIF_CONS) - else - fun _ => I) i2 - else - fun _ => I) i1 - | _ => I - end. - Lemma bool_dec_same2 (x y : Datatypes.bool) (H1 H2 : x = y) (HH1 HH2 : H1 = H2) : HH1 = HH2. Proof. apply Eqdep_dec.UIP_dec. @@ -287,34 +211,43 @@ Module Untyper(C : ContractContext). f_equal; apply bool_dec_same. Qed. - Definition tail_fail_change_range {self_type} A B B' (i : syntax.instruction self_type true A B) : - syntax.instruction self_type true A B'. + Definition tail_fail_change_range_seq {self_type} A B B' (i : syntax.instruction_seq self_type true A B) : + syntax.instruction_seq self_type true A B'. Proof. - apply (tail_fail_induction self_type A B i (fun self_type A B i => syntax.instruction self_type true A B')); clear A B i. + apply (tail_fail_induction_seq self_type A B i (fun self_type A B i => syntax.instruction self_type true A B') + (fun self_type A B i => syntax.instruction_seq self_type true A B')); clear A B i. - intros st a A _. apply syntax.FAILWITH. + - intros st A B C1 C2 t f _ _ i1 i2. + apply (syntax.IF_ f i1 i2). - intros st A B C i1 _ i2. apply (syntax.SEQ i1 i2). - - intros st A B _ _ i1 i2. - apply (syntax.IF_ i1 i2). - - intros st a A B _ _ i1 i2. - apply (syntax.IF_NONE i1 i2). - - intros st a b A B _ _ i1 i2. - apply (syntax.IF_LEFT i1 i2). - - intros st a A B _ _ i1 i2. - apply (syntax.IF_CONS i1 i2). + - intros st A B _ i. + apply (syntax.Tail_fail i). + - intros st A B _ i. + apply (syntax.Instruction_seq i). Defined. - Lemma tail_fail_change_range_same {self_type} A B (i : syntax.instruction self_type true A B) : tail_fail_change_range A B B i = i. Proof. - apply (tail_fail_induction _ A B i); clear A B i; - intros; unfold tail_fail_change_range; simpl; f_equal; assumption. + apply (tail_fail_induction _ A B i + (fun st A B i => tail_fail_change_range A B B i = i) + (fun st A B i => tail_fail_change_range_seq A B B i = i)); clear A B i; + intros; unfold tail_fail_change_range, tail_fail_change_range_seq; simpl; f_equal; assumption. + Qed. + + Lemma tail_fail_change_range_same_seq {self_type} A B (i : syntax.instruction_seq self_type true A B) : + tail_fail_change_range_seq A B B i = i. + Proof. + apply (tail_fail_induction_seq _ A B i + (fun st A B i => tail_fail_change_range A B B i = i) + (fun st A B i => tail_fail_change_range_seq A B B i = i)); clear A B i; + intros; unfold tail_fail_change_range, tail_fail_change_range_seq; simpl; f_equal; assumption. Qed. Definition untype_type_spec {self_type} tffi A B (i : syntax.instruction self_type tffi A B) := - typer.type_instruction (untype_instruction i) A = + typer.type_instruction (typer.Optimized) (untype_instruction untype_Optimized i) A = Return ((if tffi return syntax.instruction self_type tffi A B -> typer.typer_result A then fun i => @@ -322,6 +255,15 @@ Module Untyper(C : ContractContext). else typer.Inferred_type _ B) i). + Definition untype_type_spec_seq {self_type} tffi A B (i : syntax.instruction_seq self_type tffi A B) := + typer.type_instruction_seq typer.Optimized (untype_instruction_seq untype_Optimized i) A = + Return ((if tffi return syntax.instruction_seq self_type tffi A B -> typer.typer_result_seq A + then + fun i => + typer.Any_type_seq _ (fun B' => tail_fail_change_range_seq A B B' i) + else + typer.Inferred_type_seq _ B) i). + Lemma instruction_cast_same {self_type} tffi A B (i : syntax.instruction self_type tffi A B) : typer.instruction_cast A A B B i = Return i. Proof. @@ -331,21 +273,52 @@ Module Untyper(C : ContractContext). reflexivity. Qed. + Lemma instruction_seq_cast_same {self_type} tffi A B (i : syntax.instruction_seq self_type tffi A B) : + typer.instruction_seq_cast A A B B i = Return i. + Proof. + unfold typer.instruction_seq_cast. + rewrite stype_dec_same. + rewrite stype_dec_same. + reflexivity. + Qed. + + Lemma opcode_cast_same {self_type} A B + (o : syntax.opcode (self_type := self_type) A B) : + typer.opcode_cast A A B B o = Return o. + Proof. + unfold typer.opcode_cast. + rewrite stype_dec_same. + rewrite stype_dec_same. + reflexivity. + Qed. + Lemma instruction_cast_range_same {self_type} tffi A B (i : syntax.instruction self_type tffi A B) : typer.instruction_cast_range A B B i = Return i. Proof. apply instruction_cast_same. Qed. + Lemma instruction_seq_cast_range_same {self_type} tffi A B (i : syntax.instruction_seq self_type tffi A B) : + typer.instruction_seq_cast_range A B B i = Return i. + Proof. + apply instruction_seq_cast_same. + Qed. + Lemma instruction_cast_domain_same {self_type} tffi A B (i : syntax.instruction self_type tffi A B) : typer.instruction_cast_domain A A B i = Return i. Proof. apply instruction_cast_same. Qed. + Lemma opcode_cast_domain_same self_type A B (o : @syntax.opcode self_type A B) : + typer.opcode_cast_domain self_type A A B o = Return o. + Proof. + apply opcode_cast_same. + Qed. + Lemma untype_type_check_instruction {self_type} tffi A B (i : syntax.instruction self_type tffi A B) : untype_type_spec _ _ _ i -> - typer.type_check_instruction typer.type_instruction (untype_instruction i) A B = + typer.type_check_instruction (typer.type_instruction typer.Optimized) (untype_instruction untype_Optimized i) A B = Return (existT _ tffi i). Proof. intro IH. @@ -359,21 +332,37 @@ Module Untyper(C : ContractContext). reflexivity. Qed. - Lemma untype_type_check_instruction_no_tail_fail {self_type} A B (i : syntax.instruction self_type false A B) : - untype_type_spec _ _ _ i -> - typer.type_check_instruction_no_tail_fail typer.type_instruction (untype_instruction i) A B = + Lemma untype_type_check_instruction_seq {self_type} tffi A B (i : syntax.instruction_seq self_type tffi A B) : + untype_type_spec_seq _ _ _ i -> + typer.type_check_instruction_seq (typer.type_instruction_seq typer.Optimized) (untype_instruction_seq untype_Optimized i) A B = + Return (existT _ tffi i). + Proof. + intro IH. + unfold typer.type_check_instruction_seq. + rewrite IH. + simpl. + destruct tffi. + - rewrite tail_fail_change_range_same_seq. + reflexivity. + - rewrite instruction_seq_cast_range_same. + reflexivity. + Qed. + + Lemma untype_type_check_instruction_seq_no_tail_fail {self_type} A B (i : syntax.instruction_seq self_type false A B) : + untype_type_spec_seq _ _ _ i -> + typer.type_check_instruction_seq_no_tail_fail (typer.type_instruction_seq typer.Optimized) (untype_instruction_seq untype_Optimized i) A B = Return i. Proof. intro IH. - unfold typer.type_check_instruction_no_tail_fail. + unfold typer.type_check_instruction_seq_no_tail_fail. rewrite IH. simpl. - apply instruction_cast_range_same. + apply instruction_seq_cast_range_same. Qed. Lemma untype_type_instruction_no_tail_fail {self_type} A B (i : syntax.instruction self_type false A B) : untype_type_spec _ _ _ i -> - typer.type_instruction_no_tail_fail typer.type_instruction (untype_instruction i) A = Return (existT _ _ i). + typer.type_instruction_no_tail_fail (typer.type_instruction typer.Optimized) (untype_instruction untype_Optimized i) A = Return (existT _ _ i). Proof. intro IH. unfold typer.type_instruction_no_tail_fail. @@ -381,55 +370,14 @@ Module Untyper(C : ContractContext). reflexivity. Qed. - Inductive IF_instruction : forall (A1 A2 A : Datatypes.list type), Set := - | IF_i A : IF_instruction A A (bool ::: A) - | IF_NONE_i a A : IF_instruction A (a ::: A) (option a ::: A) - | IF_LEFT_i a b A : IF_instruction (a ::: A) (b ::: A) (or a b ::: A) - | IF_CONS_i a A : IF_instruction (a ::: list a ::: A) A (list a ::: A). - - Definition IF_instruction_to_instruction {self_type} A1 A2 A (IFi : IF_instruction A1 A2 A) : - forall B tffa tffb, - syntax.instruction self_type tffa A1 B -> - syntax.instruction self_type tffb A2 B -> syntax.instruction self_type (tffa && tffb) A B := - match IFi with - | IF_i A => fun B ttffa tffb i1 i2 => syntax.IF_ i1 i2 - | IF_NONE_i a A => fun B ttffa tffb i1 i2 => syntax.IF_NONE i1 i2 - | IF_LEFT_i a b A => fun B ttffa tffb i1 i2 => syntax.IF_LEFT i1 i2 - | IF_CONS_i a A => fun B ttffa tffb i1 i2 => syntax.IF_CONS i1 i2 - end. - - Lemma untype_type_branches {self_type} tff1 tff2 A1 A2 A B - (i1 : syntax.instruction self_type tff1 A1 B) - (i2 : syntax.instruction self_type tff2 A2 B) IF_instr : - untype_type_spec _ _ _ i1 -> - untype_type_spec _ _ _ i2 -> - typer.type_branches typer.type_instruction - (untype_instruction i1) - (untype_instruction i2) - A1 A2 A (IF_instruction_to_instruction A1 A2 A IF_instr) = - Return ((if (tff1 && tff2)%bool - as b return syntax.instruction self_type b A B -> typer.typer_result A - then - fun i => - typer.Any_type _ (fun B' => tail_fail_change_range A B B' i) - else - typer.Inferred_type _ B) (IF_instruction_to_instruction A1 A2 A IF_instr B tff1 tff2 i1 i2)). + Lemma untype_type_instruction_seq_no_tail_fail {self_type} A B (i : syntax.instruction_seq self_type false A B) : + untype_type_spec_seq _ _ _ i -> + typer.type_instruction_seq_no_tail_fail (typer.type_instruction_seq typer.Optimized) (untype_instruction_seq untype_Optimized i) A = Return (existT _ _ i). Proof. - intros IH1 IH2. - unfold typer.type_branches. - rewrite IH1. - rewrite IH2. - simpl. - destruct tff1; destruct tff2; simpl. - - f_equal. - f_equal. - destruct IF_instr; simpl; unfold tail_fail_change_range; reflexivity. - - rewrite tail_fail_change_range_same. - reflexivity. - - rewrite tail_fail_change_range_same. - reflexivity. - - rewrite instruction_cast_range_same. - reflexivity. + intro IH. + unfold typer.type_instruction_seq_no_tail_fail. + rewrite IH. + reflexivity. Qed. Ltac trans_refl t := transitivity t; [reflexivity|]. @@ -449,13 +397,71 @@ Module Untyper(C : ContractContext). specialize (IHl1 l1' l2 l2' (eq_add_S _ _ Hlen) Happ2) as [Hl1 Hl2]. subst. auto. Qed. + Lemma untype_type_opcode self_type A B (o : @syntax.opcode self_type A B) : + typer.type_opcode (untype_opcode o) A = Return (existT _ B o). + Proof. + destruct o; simpl; try reflexivity; + try (destruct s as [v]; destruct v; reflexivity); + try (destruct s as [c v]; destruct v; reflexivity); + try (destruct i as [v]; destruct v; reflexivity); + try (destruct i as [v]; destruct v; rewrite opcode_cast_domain_same; reflexivity); + try (rewrite opcode_cast_domain_same; reflexivity). + - pose (A := a :: lambda (pair a b) c :: D). + assert (forall (b : Datatypes.bool) i1, + (if b return is_packable a = b -> _ + then fun h => + let! o := opcode_cast_domain self_type A A _ (@syntax.APPLY _ _ _ _ _ (IT_eq_rev _ h)) in + Return (existT _ _ o) + else fun _ => Failed _ (Typing _ "APPLY"%string)) i1 + = Return (existT _ _ (@syntax.APPLY _ _ _ _ _ i))). + * intros b0 i1. + destruct b0. + -- rewrite opcode_cast_domain_same. + simpl. + repeat f_equal. + apply Is_true_UIP. + -- exfalso. + rewrite i1 in i. + exact i. + * apply H. + - destruct s as [c d v]; destruct v; reflexivity. + - simpl. + rewrite as_comparable_comparable. + destruct a; simpl. + * rewrite opcode_cast_domain_same. + reflexivity. + * rewrite opcode_cast_domain_same. + simpl. + reflexivity. + - destruct i as [x v]; destruct v; rewrite opcode_cast_domain_same; reflexivity. + - unfold type_check_dig. + simpl. + rewrite (take_n_length n S1 (t ::: S2) e). + simpl. + rewrite opcode_cast_domain_same. + reflexivity. + - unfold type_check_dug. + simpl. + rewrite (take_n_length n S1 S2 e). + simpl. + rewrite opcode_cast_domain_same. + reflexivity. + - rewrite (take_n_length n A B e). + simpl. + rewrite opcode_cast_domain_same. + reflexivity. + Qed. + Fixpoint untype_type_data a (d : syntax.concrete_data a) : - typer.type_data (untype_data d) a = Return d + typer.type_data typer.Optimized (untype_data untype_Optimized d) a = Return d with untype_type_instruction {self_type} tffi A B (i : syntax.instruction self_type tffi A B) : - untype_type_spec _ _ _ i. + untype_type_spec _ _ _ i + with + untype_type_instruction_seq {self_type} tffi A B (i : syntax.instruction_seq self_type tffi A B) : + untype_type_spec_seq _ _ _ i. Proof. - - destruct d; try reflexivity. + - destruct d; try reflexivity; try (simpl; repeat rewrite untype_type_data; reflexivity). + simpl. assert (0 <= Z.of_N n)%Z as H by apply N2Z.is_nonneg. rewrite <- Z.geb_le in H. @@ -464,69 +470,21 @@ Module Untyper(C : ContractContext). reflexivity. + simpl. destruct m. - trans_refl ( - let! m := tez.of_Z (tez.to_Z m) in - Return (syntax.Mutez_constant (Mk_mutez m)) - ). + unfold type_data. rewrite tez.of_Z_to_Z. reflexivity. + simpl. - destruct a. - simpl. - reflexivity. - + simpl. - destruct cst. - simpl. - unfold type_contract_data. - cut (forall tyopt H, type_contract_data_aux (Mk_contract s) a tyopt H = - Return (Contract_constant (Mk_contract s) e)). - * intro H. apply H. - * intros tyopt H. - destruct tyopt. - -- simpl. - destruct (type_dec a t). - ++ unfold contract_cast. - repeat f_equal. - apply Eqdep_dec.eq_proofs_unicity. - intros; repeat decide equality. - ++ congruence. - -- congruence. + destruct a as [c|c]; destruct c; simpl; reflexivity. + simpl. - trans_refl ( - let! x := typer.type_data (untype_data d1) a in - let! y := typer.type_data (untype_data d2) b in - Return (@syntax.Pair a b x y) - ). - rewrite (untype_type_data _ d1). - rewrite (untype_type_data _ d2). - reflexivity. - + trans_refl ( - let! x := typer.type_data (untype_data d) a in - Return (@syntax.Left a b x) - ). - rewrite (untype_type_data _ d). - reflexivity. - + trans_refl ( - let! x := typer.type_data (untype_data d) b in - Return (@syntax.Right a b x) - ). - rewrite (untype_type_data _ d). - reflexivity. - + trans_refl ( - let! x := typer.type_data (untype_data d) a in - Return (@syntax.Some_ a x) - ). - rewrite (untype_type_data _ d). - reflexivity. - + pose (fix type_data_list (l : Datatypes.list concrete_data) := + pose (fix type_data_list (l : Datatypes.list concrete_data) := match l with | nil => Return nil | cons x l => - let! x := typer.type_data x a in + let! x := typer.type_data typer.Optimized x a in let! l := type_data_list l in Return (cons x l) end) as type_data_list. - assert (forall l, type_data_list (List.map (fun x => untype_data x) l) = Return l). + assert (forall l, type_data_list (List.map (untype_data untype_Optimized) l) = Return l). * clear l. intro l; induction l. -- reflexivity. @@ -534,21 +492,18 @@ Module Untyper(C : ContractContext). rewrite untype_type_data. rewrite IHl. reflexivity. - * trans_refl ( - let! l := type_data_list (List.map (fun x => untype_data x) l) in - Return (@syntax.Concrete_list a l) - ). + * simpl. rewrite H. reflexivity. + pose (fix type_data_set (l : Datatypes.list concrete_data) := match l with | nil => Return nil | cons x l => - let! x := typer.type_data x a in + let! x := typer.type_data typer.Optimized x a in let! l := type_data_set l in Return (cons x l) end) as type_data_set. - assert (forall l, type_data_set (List.map (fun x => untype_data x) l) = Return l). + assert (forall l, type_data_set (List.map (untype_data untype_Optimized) l) = Return l). * clear l. intro l; induction l. -- reflexivity. @@ -556,23 +511,42 @@ Module Untyper(C : ContractContext). rewrite untype_type_data. rewrite IHl. reflexivity. - * trans_refl ( - let! l := type_data_set (List.map (fun x => untype_data x) l) in - Return (@syntax.Concrete_set a l) - ). + * simpl. rewrite H. reflexivity. + pose (fix type_data_list L := match L with | nil => Return nil | cons (Elt x y) l => - let! x := type_data x a in - let! y := type_data y b in + let! x := type_data typer.Optimized x a in + let! y := type_data typer.Optimized y b in let! l := type_data_list l in Return (cons (syntax.Elt _ _ x y) l) - | _ => Failed _ (Typing _ (untype_data (syntax.Concrete_map l), (map a b))) + | _ => Failed _ (Typing _ (untype_data untype_Optimized (syntax.Concrete_map l), (map a b))) end) as type_data_map. - assert (forall l, type_data_map (List.map (fun '(syntax.Elt _ _ x y) => Elt (untype_data x) (untype_data y)) l) = Return l). + assert (forall l, type_data_map (List.map (fun '(syntax.Elt _ _ x y) => Elt (untype_data untype_Optimized x) (untype_data untype_Optimized y)) l) = Return l). + * intro L; induction L. + -- reflexivity. + -- simpl. + destruct a0. + rewrite untype_type_data. + rewrite untype_type_data. + rewrite IHL. + reflexivity. + * simpl. + rewrite H. + reflexivity. + + pose (fix type_data_list L := + match L with + | nil => Return nil + | cons (Elt x y) l => + let! x := type_data Optimized x a in + let! y := type_data Optimized y b in + let! l := type_data_list l in + Return (cons (syntax.Elt _ _ x y) l) + | _ => Failed _ (Typing _ (untype_data untype_Optimized (syntax.Concrete_big_map l), (big_map a b))) + end) as type_data_map. + assert (forall l, type_data_map (List.map (fun '(syntax.Elt _ _ x y) => Elt (untype_data untype_Optimized x) (untype_data untype_Optimized y)) l) = Return l). * intro L; induction L. -- reflexivity. -- simpl. @@ -582,223 +556,562 @@ Module Untyper(C : ContractContext). rewrite IHL. reflexivity. * trans_refl ( - let! l := type_data_map (List.map (fun '(syntax.Elt _ _ x y) => Elt (untype_data x) (untype_data y)) l) in - Return (@syntax.Concrete_map a b l) + let! l := type_data_map (List.map (fun '(syntax.Elt _ _ x y) => Elt (untype_data untype_Optimized x) (untype_data untype_Optimized y)) l) in + Return (@syntax.Concrete_big_map a b l) ). rewrite H. reflexivity. + simpl. - rewrite untype_type_check_instruction; auto. + rewrite untype_type_check_instruction_seq; auto. + simpl. destruct c. simpl. reflexivity. - destruct i; try reflexivity; simpl. - + trans_refl ( - let! existT _ B i1 := - typer.type_instruction_no_tail_fail typer.type_instruction - (untype_instruction i1) A in - let! r2 := typer.type_instruction (untype_instruction i2) B in - match r2 with - | typer.Inferred_type _ C i2 => - Return (typer.Inferred_type _ _ (syntax.SEQ (i1 : syntax.instruction self_type _ _ _) i2)) - | typer.Any_type _ i2 => - Return (typer.Any_type _ (fun C => syntax.SEQ i1 (i2 C))) - end - ). - rewrite untype_type_instruction_no_tail_fail. - * simpl. - rewrite untype_type_instruction. - destruct tff0; reflexivity. - * auto. - + simpl. - trans_refl - (@typer.type_branches self_type - typer.type_instruction - (untype_instruction i1) - (untype_instruction i2) _ _ _ - (IF_instruction_to_instruction _ _ _ (IF_i A))). - rewrite untype_type_branches; auto. - + trans_refl ( - let! i := typer.type_check_instruction_no_tail_fail - typer.type_instruction (untype_instruction i0) A (bool ::: A) in - Return (@typer.Inferred_type self_type _ _ (syntax.LOOP i)) - ). - rewrite untype_type_check_instruction_no_tail_fail; auto. - + trans_refl ( - let! i := typer.type_check_instruction_no_tail_fail - typer.type_instruction (untype_instruction i0) _ (or a b ::: A) in - Return (@typer.Inferred_type self_type _ _ (syntax.LOOP_LEFT i)) - ). - rewrite untype_type_check_instruction_no_tail_fail; auto. + unfold untype_type_spec. simpl. - rewrite instruction_cast_domain_same. - reflexivity. + rewrite untype_type_instruction_seq. + destruct tff; reflexivity. + + unfold untype_type_spec. + simpl. + unfold type_branches. + assert (type_if_family (untype_if_family i) t = Return (existT _ C1 (existT _ C2 i))) as Hi. + * destruct i; reflexivity. + * rewrite Hi. + simpl. + rewrite untype_type_instruction_seq; simpl. + rewrite untype_type_instruction_seq; simpl. + destruct tffa; destruct tffb; + try rewrite instruction_seq_cast_range_same; simpl; repeat f_equal; apply tail_fail_change_range_same_seq. + + unfold untype_type_spec. + simpl. + unfold type_loop. + assert (type_loop_family (untype_loop_family i) t = Return (existT _ C1 (existT _ C2 i))) as Hi. + * destruct i; reflexivity. + * rewrite Hi. + simpl. + rewrite untype_type_check_instruction_seq_no_tail_fail. + -- reflexivity. + -- apply untype_type_instruction_seq. + unfold untype_type_spec. simpl. - pose (A := a :: lambda (pair a b) c :: D). - assert (forall (b : Datatypes.bool) i1, - (if b return is_packable a = b -> _ - then fun i => - let! i := instruction_cast_domain A A _ (@syntax.APPLY self_type _ _ _ _ (IT_eq_rev _ i)) in - Return (Inferred_type _ _ i) - else fun _ => Failed _ (Typing _ "APPLY"%string)) i1 - = Return (Inferred_type A _ (@syntax.APPLY _ _ _ _ _ i0))). - * intros b0 i1. - destruct b0. - -- rewrite instruction_cast_domain_same. - simpl. - repeat f_equal. - apply Is_true_UIP. - -- exfalso. - rewrite i1 in i0. - exact i0. - * apply H. - + trans_refl ( - let! d := typer.type_data (untype_data x) a in - Return (@typer.Inferred_type self_type A _ (syntax.PUSH a d)) - ). rewrite untype_type_data. reflexivity. - + trans_refl ( - let! existT _ tff i := - typer.type_check_instruction - typer.type_instruction (untype_instruction i0) (a :: nil) (b :: nil) in - Return (@typer.Inferred_type self_type _ (lambda a b ::: A) (syntax.LAMBDA a b i)) - ). - rewrite untype_type_check_instruction; auto. - + destruct s as [v]; destruct v; reflexivity. - + destruct s as [v]; destruct v; reflexivity. - + destruct s as [v]; destruct v; reflexivity. - + destruct s as [a v]; destruct v; reflexivity. - + destruct s as [v]; destruct v; reflexivity. - + destruct s as [c v]; destruct v; reflexivity. - + destruct s as [c v]; destruct v; reflexivity. - + destruct s as [c v]; destruct v; reflexivity. - + destruct s as [c d v]; destruct v; reflexivity. + unfold untype_type_spec. simpl. - rewrite as_comparable_comparable. - destruct a; simpl. - * rewrite instruction_cast_domain_same. - reflexivity. - * rewrite instruction_cast_domain_same. - simpl. - reflexivity. - + destruct i0 as [v]; destruct v; reflexivity. - + destruct i0 as [v]; destruct v; reflexivity. - + destruct i0 as [v]; destruct v; reflexivity. - + destruct i0 as [v]; destruct v; reflexivity. - + destruct i0 as [v]; destruct v. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + destruct i0 as [v]; destruct v. + rewrite untype_type_check_instruction_seq; auto. + + destruct i as [c v]; destruct v. * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. + rewrite untype_type_check_instruction_seq_no_tail_fail; auto. * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + destruct i0 as [c v]; destruct v. + rewrite untype_type_check_instruction_seq_no_tail_fail; auto. * unfold untype_type_spec; simpl. - rewrite untype_type_check_instruction_no_tail_fail; auto. - * unfold untype_type_spec; simpl. - rewrite untype_type_check_instruction_no_tail_fail; auto. - * unfold untype_type_spec; simpl. - rewrite untype_type_check_instruction_no_tail_fail; auto. - + destruct i0 as [c v]; destruct v. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - * unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + destruct i0 as [a c v]; destruct v. + rewrite untype_type_check_instruction_seq_no_tail_fail; auto. + + destruct i as [a c v]; destruct v. * unfold untype_type_spec; simpl. - rewrite untype_type_instruction_no_tail_fail. + rewrite untype_type_instruction_seq_no_tail_fail. -- simpl. - rewrite instruction_cast_range_same. + rewrite instruction_seq_cast_range_same. reflexivity. -- auto. * unfold untype_type_spec; simpl. - rewrite untype_type_instruction_no_tail_fail. + rewrite untype_type_instruction_seq_no_tail_fail. -- simpl. - rewrite instruction_cast_range_same. + rewrite instruction_seq_cast_range_same. reflexivity. -- auto. - + trans_refl - (@typer.type_branches self_type - typer.type_instruction - (untype_instruction i1) - (untype_instruction i2) _ _ _ - (IF_instruction_to_instruction _ _ _ (IF_NONE_i a A))). - rewrite untype_type_branches; auto. - + trans_refl - (@typer.type_branches self_type - typer.type_instruction - (untype_instruction i1) - (untype_instruction i2) _ _ _ - (IF_instruction_to_instruction _ _ _ (IF_LEFT_i a b A))). - rewrite untype_type_branches; auto. + unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + trans_refl - (@typer.type_branches self_type - typer.type_instruction - (untype_instruction i1) - (untype_instruction i2) _ _ _ - (IF_instruction_to_instruction _ _ _ (IF_CONS_i a A))). - rewrite untype_type_branches; auto. - + unfold untype_type_spec; simpl. - rewrite untype_type_check_instruction. + rewrite untype_type_check_instruction_seq. -- simpl. rewrite instruction_cast_domain_same. reflexivity. -- auto. + unfold untype_type_spec; simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + unfold untype_type_spec. - simpl. unfold type_check_dig. - simpl. - rewrite (take_n_length n S1 (t ::: S2) e). - simpl. - rewrite instruction_cast_domain_same. - reflexivity. - + unfold untype_type_spec. - simpl. unfold type_check_dug. - simpl. - rewrite (take_n_length n S1 S2 e). - simpl. + assert (isSome_maybe (Typing string "No such self entrypoint"%string) + (get_entrypoint_opt annot_opt self_type self_annot) = Return H). + * destruct (get_entrypoint_opt annot_opt self_type self_annot) as [x|]. + -- simpl. + destruct H. + reflexivity. + -- inversion H. + * rewrite H0. + reflexivity. + + unfold untype_type_spec; simpl. rewrite instruction_cast_domain_same. reflexivity. + unfold untype_type_spec. simpl. rewrite (take_n_length n A B e). simpl. - rewrite untype_type_instruction_no_tail_fail. + rewrite untype_type_instruction_seq_no_tail_fail. * simpl. rewrite instruction_cast_domain_same. reflexivity. - * apply untype_type_instruction. + * apply untype_type_instruction_seq. + unfold untype_type_spec. simpl. - rewrite (take_n_length n A B e). + rewrite untype_type_opcode. + reflexivity. + - destruct i; try reflexivity; simpl. + + unfold untype_type_spec_seq. + simpl. + rewrite untype_type_instruction. simpl. - rewrite instruction_cast_domain_same. reflexivity. + + unfold untype_type_spec_seq. + simpl. + rewrite untype_type_instruction. + simpl. + rewrite untype_type_instruction_seq. + simpl. + destruct tff; reflexivity. + Qed. + + Lemma type_untype_cast_seq um self_type A B C D tff i i' : + instruction_seq_cast (self_type := self_type) (tff := tff) A B C D i = Return i' -> + untype_instruction_seq um i = untype_instruction_seq um i'. + Proof. + unfold instruction_seq_cast. + destruct (stype_dec A B); [| discriminate]. + destruct (stype_dec C D); [| discriminate]. + destruct e. + destruct e0. + simpl. + intro H; apply unreturn in H. + congruence. + Qed. + + Lemma type_untype_cast um self_type A B C D tff i i' : + instruction_cast (self_type := self_type) (tff := tff) A B C D i = Return i' -> + untype_instruction um i = untype_instruction um i'. + Proof. + unfold instruction_cast. + destruct (stype_dec A B); [| discriminate]. + destruct (stype_dec C D); [| discriminate]. + destruct e. + destruct e0. + simpl. + intro H; apply unreturn in H. + congruence. + Qed. + + Lemma type_untype_cast_opcode self_type A B C D i i' : + opcode_cast (self_type := self_type) A B C D i = Return i' -> + untype_opcode i = untype_opcode i'. + Proof. + unfold opcode_cast. + destruct (stype_dec A B); [| discriminate]. + destruct (stype_dec C D); [| discriminate]. + destruct e. + destruct e0. + simpl. + intro H; apply unreturn in H. + congruence. + Qed. + + Lemma type_untype_if_family f t A B ff : + type_if_family f t = Return (existT _ A (existT _ B ff)) -> + untype_if_family ff = f. + Proof. + destruct f; destruct ff; try discriminate; simpl; reflexivity. + Qed. + + Lemma type_untype_loop_family f t A B ff : + type_loop_family f t = Return (existT _ A (existT _ B ff)) -> + untype_loop_family ff = f. + Proof. + destruct f; destruct ff; try discriminate; simpl; reflexivity. + Qed. + + Ltac mytac type_untype type_untype_seq type_untype_data := + match goal with + | |- _ -> _ => + intro + | H : (bind _ _ = Return _) |- _ => + rewrite error.bind_eq_return in H + | H : (exists _, _) |- _ => + destruct H + | H : (_ /\ _) |- _ => + destruct H + | H : (Return _ = Return _) |- _ => + apply unreturn in H + | H : (Failed _ _ = Return _) |- _ => + discriminate + | H : (match ?x with | Any_type_seq _ _ => _ | Inferred_type_seq _ _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | Any_type _ _ => _ | Inferred_type _ _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | existT _ _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | exist _ _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | (_, _) => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | nil => _ | cons _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | nil => _ | cons _ _ => _ end _ = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | None => _ | Some _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : (match ?x with | NOOP => _ | SEQ _ _ => _ end = Return _) |- _ => + is_var x; destruct x + | H : _ = ?x |- _ => + is_var x; subst x + | H : ?x = _ |- _ => + is_var x; subst x + | H : type_instruction_seq _ _ _ = Return _ |- _ => + apply type_untype_seq in H + | H : type_instruction _ _ _ = Return _ |- _ => + apply type_untype in H + | H : type_data _ _ _ = Return _ |- _ => + apply type_untype_data in H + | H : type_if_family _ _ = Return (existT _ _ (existT _ _ _)) |- _ => + apply type_untype_if_family in H + | H : type_loop_family _ _ = Return (existT _ _ (existT _ _ _)) |- _ => + apply type_untype_loop_family in H + | H : instruction_seq_cast_range _ _ _ _ = Return _ |- _ => + unfold instruction_seq_cast_range in H + | H : instruction_seq_cast _ _ _ _ _ = Return _ |- _ => + apply (type_untype_cast_seq untype_Optimized) in H + | H : instruction_cast _ _ _ _ _ = Return _ |- _ => + apply (type_untype_cast untype_Optimized) in H + | H : opcode_cast _ _ _ _ _ = Return _ |- _ => + apply type_untype_cast_opcode in H + | H : instruction_cast_domain _ _ _ _ = Return _ |- _ => + unfold instruction_cast_domain in H + | H : opcode_cast_domain _ _ _ _ _ = Return _ |- _ => + unfold opcode_cast_domain in H + | H : type_check_instruction_seq _ _ _ _ = Return _ |- _ => + unfold type_check_instruction_seq in H + | H : type_check_instruction_seq_no_tail_fail _ _ _ _ = Return _ |- _ => + unfold type_check_instruction_seq_no_tail_fail in H + | H : type_instruction_seq_no_tail_fail _ _ _ = Return _ |- _ => + unfold type_instruction_seq_no_tail_fail in H + | H : assert_not_tail_fail_seq _ _ = Return _ |- _ => + unfold assert_not_tail_fail_seq in H + | H : match ?x with + | Comparable_type _ => _ + | key => _ + | unit => _ + | signature => _ + | option _ => _ + | list _ => _ + | set _ => _ + | contract _ => _ + | operation => _ + | pair _ _ => _ + | or _ _ _ _ => _ + | lambda _ _ => _ + | map _ _ => _ + | big_map _ _ => _ + | chain_id => _ + end = Return _ |- _ => + destruct x; try discriminate + | H : match ?x with + | syntax_type.string => _ + | nat => _ + | int => _ + | bytes => _ + | bool => _ + | mutez => _ + | address => _ + | key_hash => _ + | timestamp => _ + end = Return _ |- _ => + destruct x; try discriminate + | H : (existT _ _ _ = existT _ _ _) |- _ => + apply existT_eq_3 in H; destruct H + | H : (untype_instruction_seq _ + (eq_rec _ _ _ _ eq_refl) = _) |- _ => + simpl in H + | H : (untype_instruction _ + (syntax.CREATE_CONTRACT _ _ _ + (eq_rec _ _ _ _ eq_refl)) = _) |- _ => + simpl in H + | H : (untype_instruction _ + (syntax.DIP _ _ + (eq_rec _ _ _ _ eq_refl)) = _) |- _ => + simpl in H + | |- _ = _ => + simpl in *; f_equal; congruence + end. + + Lemma type_untype_opcode self_type A B o (o' : syntax.opcode A B) : + typer.type_opcode (self_type := self_type) o A = + error.Return (existT _ B o') -> + untype_opcode o' = o. + Proof. + destruct o; simpl. + - destruct A; [discriminate|]. + destruct A; [discriminate|]. + destruct t0; try discriminate. + destruct t0_1; try discriminate. + match goal with + | |- + ((match ?b0 as b return _ with | true => ?th | false => ?e end) eq_refl = ?rhs -> _) => + intro Ho'; assert (exists b (Hb : is_packable t = b), + (if b return is_packable t = b -> _ + then th else e) Hb = rhs) + end. + + exists (is_packable t); exists eq_refl; exact Ho'. + + clear Ho'. + destruct H as ([|], (Hb, H)); try discriminate. + unfold typer.opcode_cast_domain in H. + repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - unfold type_check_dig. + repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - unfold type_check_dug. + repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + - repeat mytac (eq_refl Z) (eq_refl Z) (eq_refl Z). + Qed. + + Definition un_address ty (addr : syntax.concrete_data ty) : + Datatypes.option address_constant := + match addr return Datatypes.option address_constant with + | Address_constant x => Some x + | _ => None + end. + + Lemma un_address_some ty (addr : syntax.concrete_data ty) (H : ty = address) : + exists x, un_address ty addr = Some x. + Proof. + destruct addr; try discriminate. + simpl; eexists; reflexivity. Qed. -End Untyper. + Lemma un_address_some_rev ty (addr : syntax.concrete_data ty) x : + un_address ty addr = Some x -> + exists He, eq_rect ty syntax.concrete_data addr address He = Address_constant x. + Proof. + destruct addr; try discriminate. + simpl. + intro Hs; injection Hs; intro; subst x. + exists eq_refl. + reflexivity. + Qed. + + Lemma concrete_address_inversion (addr : syntax.concrete_data (Comparable_type address)) : + exists x : address_constant, + addr = Address_constant x. + Proof. + case_eq (un_address address addr). + - intros c Hc. + apply un_address_some_rev in Hc. + destruct Hc as (Haddr, H). + assert (Haddr = eq_refl) by (apply Eqdep_dec.UIP_dec; apply type_dec). + subst Haddr. + simpl in H. + eexists; eassumption. + - intro H. + destruct (un_address_some address addr eq_refl) as (c, Hc). + congruence. + Qed. + + Fixpoint type_untype self_type A i t {struct i} : + typer.type_instruction typer.Optimized (self_type := self_type) i A = error.Return t -> + match t with + | Inferred_type _ B i' => untype_instruction untype_Optimized i' = i + | Any_type _ i' => forall B, untype_instruction untype_Optimized (i' B) = i + end + with type_untype_seq self_type A i t {struct i} : + typer.type_instruction_seq typer.Optimized (self_type := self_type) i A = error.Return t -> + match t with + | Inferred_type_seq _ B i' => untype_instruction_seq untype_Optimized i' = i + | Any_type_seq _ i' => forall B, untype_instruction_seq untype_Optimized (i' B) = i + end + with type_untype_data a x (x' : syntax.concrete_data a) {struct x} : + typer.type_data typer.Optimized x a = error.Return x' -> + untype_data untype_Optimized x' = x. + Proof. + { + destruct i; simpl. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - unfold type_branches. + repeat mytac type_untype type_untype_seq type_untype_data. + - unfold type_loop. + repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + apply type_untype_opcode in H. + simpl. + f_equal. + exact H. + } + { + destruct i; simpl. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + } + { + destruct x; simpl. + - repeat mytac type_untype type_untype_seq type_untype_data. + + case_eq (z >=? 0)%Z; intro He; rewrite He in H; try discriminate. + repeat mytac type_untype type_untype_seq type_untype_data. + simpl. + rewrite Z.geb_le in He. + f_equal. + apply Z2N.id. + assumption. + + simpl. + f_equal. + apply tez.of_Z_to_Z_eqv. + assumption. + - repeat mytac type_untype type_untype_seq type_untype_data. + destruct (concrete_address_inversion x') as (x, Hx). + subst x'. + simpl. + destruct s as [|c1 [|c2 s]]; try discriminate. + destruct (ascii_dec c1 "t"). + + destruct (ascii_dec c2 "z"); try discriminate. + injection H; intros; subst x. + congruence. + + destruct s as [|c3 s]; try discriminate. + destruct (ascii_dec c1 "K"); try discriminate. + destruct (ascii_dec c2 "T"); try discriminate. + destruct (ascii_dec c3 "1"); try discriminate. + injection H; intros; subst x. + congruence. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + - repeat mytac type_untype type_untype_seq type_untype_data. + + simpl. + f_equal. + generalize dependent x. + generalize dependent l. + induction l. + * repeat mytac type_untype type_untype_seq type_untype_data. + * repeat mytac type_untype type_untype_seq type_untype_data. + simpl. + f_equal. + apply IHl. + assumption. + + simpl. + f_equal. + generalize dependent x. + generalize dependent l. + induction l. + * repeat mytac type_untype type_untype_seq type_untype_data. + * repeat mytac type_untype type_untype_seq type_untype_data. + simpl. + f_equal. + apply IHl. + assumption. + + simpl. + f_equal. + match goal with | H : ?F l = Return x |- _ => pose F as type_data_list end. + change (type_data_list l = Return x) in H. + assert (exists l', l' = l) as Hl' by (exists l; reflexivity). + rename l into linit. + destruct Hl' as (l, Hl). + rewrite <- Hl in H. + rewrite <- Hl. + clear Hl. + generalize dependent x. + induction l; simpl in *. + * repeat mytac type_untype type_untype_seq type_untype_data. + * repeat mytac type_untype type_untype_seq type_untype_data. + destruct a0; try discriminate. + repeat mytac type_untype type_untype_seq type_untype_data. + simpl. + f_equal. + apply IHl. + assumption. + + simpl. + f_equal. + match goal with | H : ?F l = Return x |- _ => pose F as type_data_list end. + change (type_data_list l = Return x) in H. + assert (exists l', l' = l) as Hl' by (exists l; reflexivity). + rename l into linit. + destruct Hl' as (l, Hl). + rewrite <- Hl in H. + rewrite <- Hl. + clear Hl. + generalize dependent x. + induction l; simpl in *. + * repeat mytac type_untype type_untype_seq type_untype_data. + * repeat mytac type_untype type_untype_seq type_untype_data. + destruct a0; try discriminate. + repeat mytac type_untype type_untype_seq type_untype_data. + simpl. + f_equal. + apply IHl. + assumption. + - repeat mytac type_untype type_untype_seq type_untype_data. + } + Qed. diff --git a/src/michocoq/util.v b/src/michocoq/util.v index be14206cfde768e45260fee10429c97aacfe102c..7a6e98bd11dd2da76ef57ddde27f4290466be16d 100644 --- a/src/michocoq/util.v +++ b/src/michocoq/util.v @@ -116,6 +116,10 @@ Proof. intuition. Qed. +Lemma or_both {P Q R S} : P <-> R -> Q <-> S -> ((P \/ Q) <-> (R \/ S)). +Proof. + intuition. +Qed. Lemma eqb_eq a c1 c2 : BinInt.Z.eqb (comparison_to_int (compare a c1 c2)) Z0 = true <-> @@ -211,3 +215,25 @@ Lemma eq_sym_iff {A : Type} (x y : A) : x = y <-> y = x. Proof. split; apply eq_sym. Qed. + +Lemma destruct_if (b : Datatypes.bool) P Q : + (if b then P else Q) <-> ((b = true /\ P ) \/ (b = false /\ Q)). +Proof. + destruct b; intuition discriminate. +Qed. + +Lemma bool_not_false b : b = false <-> ~ b = true. +Proof. + destruct b; intuition congruence. +Qed. + +Lemma match_if_exchange A B (b : Datatypes.bool) (P : A -> Prop) (Q : B -> Prop) u v : + match (if b then inl u else inr v) with + | inl x => P x + | inr y => Q y + end = + if b then P u else Q v. +Proof. + destruct b; reflexivity. +Qed. +