From 507c46bbcbf57378509c63287d8c8776fe936de9 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Wed, 11 Jan 2017 17:42:54 +0100 Subject: [PATCH] Michelson: get rid of tagged data notation. --- .../bootstrap/client_proto_programs.ml | 12 +- .../embedded/bootstrap/client_proto_rpcs.ml | 7 +- .../embedded/bootstrap/client_proto_rpcs.mli | 5 +- src/proto/bootstrap/docs/language.md | 309 ++++++++--------- src/proto/bootstrap/script_interpreter.ml | 30 +- src/proto/bootstrap/script_ir_translator.ml | 322 ++---------------- src/proto/bootstrap/services.ml | 16 +- src/proto/bootstrap/services_registration.ml | 8 +- test/scripts/hardlimit.tez | 4 +- 9 files changed, 202 insertions(+), 511 deletions(-) diff --git a/src/client/embedded/bootstrap/client_proto_programs.ml b/src/client/embedded/bootstrap/client_proto_programs.ml index 70626d645..0fdfe1cb1 100644 --- a/src/client/embedded/bootstrap/client_proto_programs.ml +++ b/src/client/embedded/bootstrap/client_proto_programs.ml @@ -210,9 +210,9 @@ let commands () = (prefixes [ "run" ; "program" ] @@ Program.source_param @@ prefixes [ "on" ; "storage" ] - @@ Cli_entries.param ~name:"storage" ~desc:"the untagged storage data" parse_data + @@ Cli_entries.param ~name:"storage" ~desc:"the storage data" parse_data @@ prefixes [ "and" ; "input" ] - @@ Cli_entries.param ~name:"storage" ~desc:"the untagged input data" parse_data + @@ Cli_entries.param ~name:"storage" ~desc:"the input data" parse_data @@ stop) (fun program storage input cctxt -> let open Data_encoding in @@ -274,7 +274,7 @@ let commands () = | Error errs -> pp_print_error Format.err_formatter errs ; cctxt.error "ill-typed program") ; - command ~group ~desc: "ask the node to typecheck a tagged data expression" + command ~group ~desc: "ask the node to typecheck a data expression" (prefixes [ "typecheck" ; "data" ] @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data @@ prefixes [ "against" ; "type" ] @@ -282,7 +282,7 @@ let commands () = @@ stop) (fun data exp_ty cctxt -> let open Data_encoding in - Client_proto_rpcs.Helpers.typecheck_untagged_data cctxt + Client_proto_rpcs.Helpers.typecheck_data cctxt (block ()) (data, exp_ty) >>= function | Ok () -> cctxt.message "Well typed" @@ -290,7 +290,7 @@ let commands () = pp_print_error Format.err_formatter errs ; cctxt.error "ill-typed data") ; command ~group - ~desc: "ask the node to compute the hash of an untagged data expression \ + ~desc: "ask the node to compute the hash of a data expression \ using the same algorithm as script instruction H" (prefixes [ "hash" ; "data" ] @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data @@ -305,7 +305,7 @@ let commands () = pp_print_error Format.err_formatter errs ; cctxt.error "ill-formed data") ; command ~group - ~desc: "ask the node to compute the hash of an untagged data expression \ + ~desc: "ask the node to compute the hash of a data expression \ using the same algorithm as script instruction H, sign it using \ a given secret key, and display it using the format expected by \ script instruction CHECK_SIGNATURE" diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.ml b/src/client/embedded/bootstrap/client_proto_rpcs.ml index 50d55ae45..e8053bb99 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.ml +++ b/src/client/embedded/bootstrap/client_proto_rpcs.ml @@ -140,11 +140,8 @@ module Helpers = struct call_error_service1 cctxt Services.Helpers.trace_code block (code, storage, input, None, None) - let typecheck_tagged_data cctxt = - call_error_service1 cctxt Services.Helpers.typecheck_tagged_data - - let typecheck_untagged_data cctxt = - call_error_service1 cctxt Services.Helpers.typecheck_untagged_data + let typecheck_data cctxt = + call_error_service1 cctxt Services.Helpers.typecheck_data let hash_data cctxt = call_error_service1 cctxt Services.Helpers.hash_data diff --git a/src/client/embedded/bootstrap/client_proto_rpcs.mli b/src/client/embedded/bootstrap/client_proto_rpcs.mli index 373919206..69b877adf 100644 --- a/src/client/embedded/bootstrap/client_proto_rpcs.mli +++ b/src/client/embedded/bootstrap/client_proto_rpcs.mli @@ -149,10 +149,7 @@ module Helpers : sig val typecheck_code: Client_commands.context -> block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t - val typecheck_tagged_data: - Client_commands.context -> - block -> Script.expr -> unit tzresult Lwt.t - val typecheck_untagged_data: + val typecheck_data: Client_commands.context -> block -> Script.expr * Script.expr -> unit tzresult Lwt.t val hash_data: diff --git a/src/proto/bootstrap/docs/language.md b/src/proto/bootstrap/docs/language.md index 2d4e92fd1..f21743f1b 100644 --- a/src/proto/bootstrap/docs/language.md +++ b/src/proto/bootstrap/docs/language.md @@ -1061,7 +1061,7 @@ for under/overflows. the global data and returns it to be stored and retrieved on the next transaction. These data are initialized by another parameter. The calling convention for the code is as follows: - (Pair (Pair amount arg) globals)) -> (Pair ret globals), as + `(Pair (Pair amount arg) globals)) -> (Pair ret globals)`, as extrapolable from the instruction type. The first parameters are the manager, optional delegate, then spendable and delegatable flags and finally the initial amount taken from the currently @@ -1154,22 +1154,14 @@ for under/overflows. VIII - Concrete syntax ---------------------- -The structure of the concrete language is extremely simple. An -expression in the language can only be one of the three following -constructs. +The concrete language is very close to the formal notation of the +specification. Its structure is extremely simple: an expression in the +language can only be one of the three following constructs. - 1. A constant. + 1. A constant (integer or string). 2. The application of a primitive to a sequence of expressions. 3. A sequence of expressions. -As in Python or Haskell, the concrete syntax of the language is -indentation sensitive. The elements of a syntactical block, such as -all the elements of a sequence, or all the parameters of a primitive, -must be written with the exact same left margin in the program source -code. This is unlike in C-like languages, where blocks are delimited -with braces and the margin is ignored by the compiled. The exact -parsing policy is described just after. - ### Constants There are two kinds of constants: @@ -1181,30 +1173,20 @@ There are two kinds of constants: characters can be escaped by 3 digits decimal codes `\ddd` or 2 digit hexadecimal codes `\xHH`. -All domain specific constants are strings: - - - `tez` amounts are written using the same notation as JSON schemas - and the command line client: thousands are optionally separated by - comas, and centiles, if present, must be prefixed by a period. - - in regexp form: `([0-9]{1,3}(,[0-9]{3})+)|[0-9]+(\.[0.9]{2})?` - - `"1234567"` means 123456700 tez centiles - - `"1,234,567"` means 123456700 tez centiles - - `"1234567.89"` means 123456789 tez centiles - - `"1,234,567.00"` means 123456789 tez centiles - - `"1234,567"` is invalid - - `"1,234,567."` is invalid - - `"1,234,567.0"` is invalid - - `timestamp`s are written using `RFC 339` notation. - - `contract`s are the raw strings returned by JSON RPCs or the command - line interface and cannot be forged by hand so their format is of - no interest here. - - `key`s are `Sha256` hashes of `ed25519` public keys encoded in - `base48` format with the following custom alphabet: - `"eXMNE9qvHPQDdcFx5J86rT7VRm2atAypGhgLfbS3CKjnksB4"`. - - `signature`s are `ed25519` signatures as a series of hex-encoded bytes. - ### Primitive applications +In the specification, primitive applications always luckily fit on a +single line. In this case, the concrete syntax is exactly the formal +notation. However, it is sometimes necessary to break lines in a real +program, which can be done as follows. + +As in Python or Haskell, the concrete syntax of the language is +indentation sensitive. The elements of a syntactical block, such as +all the elements of a sequence, or all the parameters of a primitive, +must be written with the exact same left margin in the program source +code. This is unlike in C-like languages, where blocks are delimited +with braces and the margin is ignored by the compiled. + The simplest form requires to break the line after the primitive name and after every argument. Argument must be indented by at least one more space than the primitive, and all arguments must sit on the exact @@ -1271,10 +1253,61 @@ example is: ### Sequences -Successive instructions can be grouped as a single one by grouping -them inside braces, separated by semicolons. To prevent errors, -control flow primitives that take instructions as parameters require -sequences in the concrete syntax. +Successive expression can be grouped as a single sequence expression +using braces delimiters and semicolon separators. + + { expr1 ; expr2 ; expr3 ; expr4 } + +A sequence block can be split on several lines. In this situation, the +whole block, including the closing brace, must be indented with +respect to the first instruction. + + { expr1 ; expr2 + expr3 ; expr4 } + +Blocks can be passed as argument to a primitive. + + + PRIM arg1 arg2 + { arg3_expr1 ; arg3_expr2 + arg3_expr3 ; arg3_expr4 } + + +### Conventions + +The concrete syntax follows the same lexical conventions as the +specification: instructions are represented by uppercase identifiers, +type constructors by lowercase identifiers, and constant constructors +are Capitalised. + +Lists can be written in a single shot instead of a succession of `Cons` + + (List 1 2 3) = (Cons 1 (Cons 2 (Cons 3 Nil))) + +All domain specific constants are strings with specific formats: + + - `tez` amounts are written using the same notation as JSON schemas + and the command line client: thousands are optionally separated by + comas, and centiles, if present, must be prefixed by a period. + - in regexp form: `([0-9]{1,3}(,[0-9]{3})+)|[0-9]+(\.[0.9]{2})?` + - `"1234567"` means 123456700 tez centiles + - `"1,234,567"` means 123456700 tez centiles + - `"1234567.89"` means 123456789 tez centiles + - `"1,234,567.00"` means 123456789 tez centiles + - `"1234,567"` is invalid + - `"1,234,567."` is invalid + - `"1,234,567.0"` is invalid + - `timestamp`s are written using `RFC 339` notation. + - `contract`s are the raw strings returned by JSON RPCs or the command + line interface and cannot be forged by hand so their format is of + no interest here. + - `key`s are `Sha256` hashes of `ed25519` public keys encoded in + `base48` format with the following custom alphabet: + `"eXMNE9qvHPQDdcFx5J86rT7VRm2atAypGhgLfbS3CKjnksB4"`. + - `signature`s are `ed25519` signatures as a series of hex-encoded bytes. + +To prevent errors, control flow primitives that take instructions as +parameters require sequences in the concrete syntax. IF { instr1_true ; instr2_true ; ... } { instr1_false ; instr2_false ; ... } @@ -1282,78 +1315,13 @@ sequences in the concrete syntax. { instr1_true ; instr2_true ; ... } { instr1_false ; instr2_false ; ... } -A sequence block can be split on several lines. In this situation, the -whole block, including the closing brace, must be indented with -respect to the first instruction. +### Main program structure - LAMBDA t_arg t_ret - { instr1 ; instr2 - instr3 ; instr4 } +The toplevel of a smart contract file must be an undelimited sequence +of four primitive applications (in no particular order) that provide +its `parameter`, `return` and `storage` types, as well as its `code`. -### Lexical conventions - -Instructions are represented by uppercase identifiers, type -constructor are lowercase identifiers and constant constructors are -Capitalised. - - * Types, in lowercase, in prefixed notation as in this specification: - - string - - pair string (pair int8 tez) - - lambda int8 int16 - - Of course, types can be split over multiple lines using the - common indented notation. - - map - string - uint32 - - * Constants are built using constructors (starting with a capital) - followed by the actual value. - - Int8 1 - - Compound constants such as lists, in order not to repeat the same - constant constructor for each element, take the type(s) of inner - values as first argument(s), and then the values without their - constructors. - - List int8 1 2 3 4 5 - - Pair int8 int16 1 2 - - For constructors whose type cannot be completely deduced fron a - single value, the free type variables must be specified. For this, - some constant constructors take extra types arguments as follows. - - List int8 - - None tez - - Left (Int8 3) int16 - - Right int16 (Int8 3) - - When the type is already completely specified, by a parent - constructor or as in the instruction PUSH, these annotations must - be omitted. - - Pair int8 (list int16) 1 (List 2 3) - - Pair (option (pair unit int8)) unit - None - Unit - - Pair (or int8 string) (or int8 string) - Left 3 - Right "text" - - * Instructions, in uppercase: - - ADD +See the next section for a concrete example. ### Comments @@ -1361,8 +1329,8 @@ A hash sign (`#`) anywhere outside of a string literal will make the rest of the line (and itself) completely ignored, as in the following example. - PUSH (Int8 1) # pushes 1 - PUSH (Int8 2) # pushes 2 + PUSH int8 1 # pushes 1 + PUSH int8 2 # pushes 2 ADD # computes 2 + 1 IX - Examples @@ -1386,7 +1354,14 @@ contract of such a type must take a `unit` argument, an amount in `tez`, and transform a unit global storage, and must thus be of type `(lambda (pair (pair tez unit) unit) (pair unit unit))`. -Such a minimal contract is thus `{ CDR ; UNIT ; PAIR }`. +Such a minimal contract code is thus `{ CDR ; UNIT ; PAIR }`. + +A valid contract source file would be as follows. + + code { CDR ; UNIT ; PAIR } + storage unit + parameter unit + return unit ### Reservoir contract @@ -1435,11 +1410,11 @@ its code is COMPARE ; LE IF { } # nothing to do { DUP ; CDDDR # B - BALANCE ; PUSH Unit ; TRANSFER_TOKENS ; DROP } } + BALANCE ; UNIT ; TRANSFER_TOKENS ; DROP } } { DUP ; CDDAR ; # A BALANCE ; - PUSH Unit ; TRANSFER_TOKENS ; DROP } - CDR ; PUSH Unit ; PAIR + UNIT ; TRANSFER_TOKENS ; DROP } + CDR ; UNIT ; PAIR ### Reservoir contract (variant with broker and status) @@ -1468,7 +1443,7 @@ example and must be updated according to the actual Tezos minmal value for contract balance. DUP ; CDAR # S - PUSH (String "open") ; + PUSH string "open" ; COMPARE ; NEQ ; IF { FAIL ; CDR } # on "success", "timeout" or a bad init value { DUP ; CDDAR ; # T @@ -1476,7 +1451,7 @@ value for contract balance. COMPARE ; LT ; IF { # Before timeout # We compute ((1 + P) + N) tez for keeping the contract alive - PUSH (Tez "1.00") ; + PUSH tez "1.00" ; DIP { DUP ; CDDDAAR } ; ADD ; # P DIP { DUP ; CDDDADR } ; ADD ; # N # We compare to the cumulated amount @@ -1488,32 +1463,32 @@ value for contract balance. { # We transfer the fee to the broker DUP ; CDDDAAR ; # P DIP { DUP ; CDDDDAR } # A - PUSH Unit ; TRANSFER_TOKENS ; DROP ; + UNIT ; TRANSFER_TOKENS ; DROP ; # We transfer the rest to the destination DUP ; CDDDADR ; # N DIP { DUP ; CDDDDDR } # B - PUSH Unit ; TRANSFER_TOKENS ; DROP ; + UNIT ; TRANSFER_TOKENS ; DROP ; # We update the global - CDR ; CDR ; PUSH (String "success") ; PAIR } } + CDR ; CDR ; PUSH string "success" ; PAIR } } { # After timeout # We try to transfer P tez to A - PUSH (Tez "1.00") ; BALANCE ; SUB ; # available + PUSH tez "1.00" ; BALANCE ; SUB ; # available DIP { DUP ; CDDDAAR } ;# P COMPARE ; LT ; # available < P - IF { PUSH (Tez "1.00") ; BALANCE ; SUB ; # available + IF { PUSH tez "1.00" ; BALANCE ; SUB ; # available DIP { DUP ; CDDDDAR } # A - PUSH Unit ; TRANSFER_TOKENS ; DROP } + UNIT ; TRANSFER_TOKENS ; DROP } { DUP ; CDDDAAR ; # P DIP { DUP ; CDDDDAR } # A - PUSH Unit ; TRANSFER_TOKENS ; DROP } + UNIT ; TRANSFER_TOKENS ; DROP } # We transfer the rest to B - PUSH (Tez "1.00") ; BALANCE ; SUB ; # available + PUSH tez "1.00" ; BALANCE ; SUB ; # available DIP { DUP ; CDDDDDR } # B - PUSH Unit ; TRANSFER_TOKENS ; DROP ; + UNIT ; TRANSFER_TOKENS ; DROP ; # We update the global - CDR ; CDR ; PUSH (String "timeout") ; PAIR } } + CDR ; CDR ; PUSH string "timeout" ; PAIR } } # return Unit - PUSH Unit ; PAIR + UNIT ; PAIR ### Forward contract @@ -1613,65 +1588,65 @@ with the minimum amount, set to `(Tez "1.00")`. The code of the contract is thus as follows. DUP ; CDDADDR ; # Z - PUSH (Uint64 86400) ; SWAP ; ADD ; # one day in second + PUSH uint64 86400 ; SWAP ; ADD ; # one day in second NOW ; COMPARE ; LT ; IF { # Before Z + 24 DUP ; CADR ; # we must receive (Left "buyer") or (Left "seller") IF_LEFT - { DUP ; PUSH (String "buyer") ; COMPARE ; EQ ; + { DUP ; PUSH string "buyer" ; COMPARE ; EQ ; IF { DROP ; DUP ; CDADAR ; # amount already versed by the buyer DIP { DUP ; CAAR } ; ADD ; # transaction # then we rebuild the globals DIP { DUP ; CDADDR } ; PAIR ; # seller amount - PUSH (Uint32 0) ; PAIR ; # delivery counter at 0 + PUSH uint32 0 ; PAIR ; # delivery counter at 0 DIP { CDDR } ; PAIR ; # parameters # and return Unit - PUSH Unit ; PAIR } - { PUSH (String "seller") ; COMPARE ; EQ ; + UNIT ; PAIR } + { PUSH string "seller" ; COMPARE ; EQ ; IF { DUP ; CDADDR ; # amount already versed by the seller DIP { DUP ; CAAR } ; ADD ; # transaction # then we rebuild the globals DIP { DUP ; CDADAR } ; SWAP ; PAIR ; # buyer amount - PUSH (Uint32 0) ; PAIR ; # delivery counter at 0 + PUSH uint32 0 ; PAIR ; # delivery counter at 0 DIP { CDDR } ; PAIR ; # parameters # and return Unit - PUSH Unit ; PAIR } - { FAIL ; CDR ; PUSH Unit ; PAIR }}} # (Left _) - { FAIL ; DROP ; CDR ; PUSH Unit ; PAIR }} # (Right _) + UNIT ; PAIR } + { FAIL ; CDR ; UNIT ; PAIR }}} # (Left _) + { FAIL ; DROP ; CDR ; UNIT ; PAIR }} # (Right _) { # After Z + 24 # test if the required amount is reached DUP ; CDDAAR ; # Q DIP { DUP ; CDDDADR } ; MUL ; # C - PUSH (Uint8 2) ; MUL ; - PUSH (Tez "1.00") ; ADD ; + PUSH uint8 2 ; MUL ; + PUSH tez "1.00" ; ADD ; BALANCE ; COMPARE ; LT ; # balance < 2 * (Q * C) + 1 IF { # refund the parties DUP ; CDADAR ; # amount versed by the buyer DIP { DUP ; CDDDDAAR } # B - PUSH Unit ; TRANSFER_TOKENS ; DROP + UNIT ; TRANSFER_TOKENS ; DROP DUP ; CDADDR ; # amount versed by the seller DIP { DUP ; CDDDDADR } # S - PUSH Unit ; TRANSFER_TOKENS ; DROP + UNIT ; TRANSFER_TOKENS ; DROP BALANCE ; # bonus to the warehouse to destroy the account DIP { DUP ; CDDDDDR } # W - PUSH Unit ; TRANSFER_TOKENS ; DROP + UNIT ; TRANSFER_TOKENS ; DROP # return unit, don't change the global # since the contract will be destroyed - CDR ; PUSH Unit ; PAIR } + CDR ; UNIT ; PAIR } { # otherwise continue DUP ; CDDADAR # T NOW ; COMPARE ; LT - IF { FAIL ; CDR ; PUSH Unit ; PAIR } # Between Z + 24 and T + IF { FAIL ; CDR ; UNIT ; PAIR } # Between Z + 24 and T { # after T DUP ; CDDADAR # T - PUSH (Uint64 86400) ; ADD # one day in second + PUSH uint64 86400 ; ADD # one day in second NOW ; COMPARE ; LT IF { # Between T and T + 24 # we only accept transactions from the buyer DUP ; CADR ; # we must receive (Left "buyer") IF_LEFT - { PUSH (String "buyer") ; COMPARE ; EQ ; + { PUSH string "buyer" ; COMPARE ; EQ ; IF { DUP ; CDADAR ; # amount already versed by the buyer DIP { DUP ; CAAR } ; ADD ; # transaction # The amount must not exceed Q * K @@ -1682,12 +1657,12 @@ The code of the contract is thus as follows. IF { FAIL } { } } ; # abort or continue # then we rebuild the globals DIP { DUP ; CDADDR } ; PAIR ; # seller amount - PUSH (Uint32 0) ; PAIR ; # delivery counter at 0 + PUSH uint32 0 ; PAIR ; # delivery counter at 0 DIP { CDDR } ; PAIR ; # parameters # and return Unit - PUSH Unit ; PAIR } - { FAIL ; CDR ; PUSH Unit ; PAIR }} # (Left _) - { FAIL ; DROP ; CDR ; PUSH Unit ; PAIR }} # (Right _) + UNIT ; PAIR } + { FAIL ; CDR ; UNIT ; PAIR }} # (Left _) + { FAIL ; DROP ; CDR ; UNIT ; PAIR }} # (Right _) { # After T + 24 # test if the required payment is reached DUP ; CDDAAR ; # Q @@ -1697,13 +1672,13 @@ The code of the contract is thus as follows. IF { # not reached, pay the seller and destroy the contract BALANCE ; DIP { DUP ; CDDDDADR } # S - PUSH Unit ; TRANSFER_TOKENS ; DROP ; + UNIT ; TRANSFER_TOKENS ; DROP ; # and return Unit - CDR ; PUSH Unit ; PAIR } + CDR ; UNIT ; PAIR } { # otherwise continue DUP ; CDDADAR # T - PUSH (Uint64 86400) ; ADD ; - PUSH (Uint64 86400) ; ADD ; # two days in second + PUSH uint64 86400 ; ADD ; + PUSH uint64 86400 ; ADD ; # two days in second NOW ; COMPARE ; LT IF { # Between T + 24 and T + 48 # We accept only delivery notifications, from W @@ -1713,13 +1688,13 @@ The code of the contract is thus as follows. IF { FAIL } {} # fail if not the warehouse DUP ; CADR ; # we must receive (Right amount) IF_LEFT - { FAIL ; DROP ; CDR ; PUSH Unit ; PAIR } # (Left _) + { FAIL ; DROP ; CDR ; UNIT ; PAIR } # (Left _) { # We increment the counter DIP { DUP ; CDAAR } ; ADD ; # And rebuild the globals in advance DIP { DUP ; CDADR } ; PAIR ; DIP CDDR ; PAIR ; - PUSH Unit ; PAIR ; + UNIT ; PAIR ; # We test if enough have been delivered DUP ; CDAAR ; DIP { DUP ; CDDAAR } ; @@ -1728,13 +1703,13 @@ The code of the contract is thus as follows. { # Transfer all the money to the seller BALANCE ; # and destroy the contract DIP { DUP ; CDDDDADR } # S - PUSH Unit ; TRANSFER_TOKENS ; DROP }}} + UNIT ; TRANSFER_TOKENS ; DROP }}} { # after T + 48, transfer everything to the buyer BALANCE ; # and destroy the contract DIP { DUP ; CDDDDAAR } # B - PUSH Unit ; TRANSFER_TOKENS ; DROP ; + UNIT ; TRANSFER_TOKENS ; DROP ; # and return unit - CDR ; PUSH Unit ; PAIR }}}}}} + CDR ; UNIT ; PAIR }}}}}} X - Full grammar ---------------- @@ -1750,21 +1725,21 @@ X - Full grammar | Unit | True | False - | Pair - | Left - | Right - | Some + | Pair + | Left + | Right + | Some | None - | List ... - | Set ... - | Map (Item ) ... + | List ... + | Set ... + | Map (Item ) ... | instruction ::= | { ... } | DROP | DUP | SWAP - | PUSH + | PUSH | SOME | NONE | IF_NONE { ... } { ... } diff --git a/src/proto/bootstrap/script_interpreter.ml b/src/proto/bootstrap/script_interpreter.ml index 9d0069c1d..cc5ee6ae3 100644 --- a/src/proto/bootstrap/script_interpreter.ml +++ b/src/proto/bootstrap/script_interpreter.ml @@ -70,7 +70,7 @@ let rec unparse_stack = function | Empty, Empty_t -> [] | Item (v, rest), Item_t (ty, rest_ty) -> - unparse_tagged_data ty v :: unparse_stack (rest, rest_ty) + unparse_data ty v :: unparse_stack (rest, rest_ty) let rec interp : type p r. @@ -396,7 +396,7 @@ let rec interp Contract.unconditional_spend ctxt source amount >>=? fun ctxt -> Contract.credit ctxt destination amount >>=? fun ctxt -> Contract.get_script ctxt destination >>=? fun destination_script -> - let sto = unparse_untagged_data storage_type sto in + let sto = unparse_data storage_type sto in Contract.update_script_storage ctxt source sto >>=? fun ctxt -> begin match destination_script with | No_script -> @@ -405,20 +405,20 @@ let rec interp record_trace (Invalid_contract (loc, destination))) >>=? fun (Eq _) -> return (ctxt, qta) | Script { code ; storage } -> - let p = unparse_untagged_data tp p in + let p = unparse_data tp p in execute source destination ctxt storage code amount p qta >>=? fun (csto, ret, qta, ctxt) -> Contract.update_script_storage ctxt destination csto >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) - (parse_untagged_data ctxt Unit_t ret) >>=? fun () -> + (parse_data ctxt Unit_t ret) >>=? fun () -> return (ctxt, qta) end >>=? fun (ctxt, qta) -> Contract.get_script ctxt source >>=? (function | No_script -> assert false | Script { storage = { storage } } -> - parse_untagged_data ctxt storage_type storage >>=? fun sto -> + parse_data ctxt storage_type storage >>=? fun sto -> logged_return (Item ((), Item (sto, Empty)), qta - 1, ctxt)) end | Transfer_tokens storage_type, @@ -428,20 +428,20 @@ let rec interp Contract.get_script ctxt destination >>=? function | No_script -> fail (Invalid_contract (loc, destination)) | Script { code ; storage } -> - let sto = unparse_untagged_data storage_type sto in + let sto = unparse_data storage_type sto in Contract.update_script_storage ctxt source sto >>=? fun ctxt -> - let p = unparse_untagged_data tp p in + let p = unparse_data tp p in execute source destination ctxt storage code amount p qta >>=? fun (sto, ret, qta, ctxt) -> Contract.update_script_storage ctxt destination sto >>=? fun ctxt -> trace (Invalid_contract (loc, destination)) - (parse_untagged_data ctxt tr ret) >>=? fun v -> + (parse_data ctxt tr ret) >>=? fun v -> Contract.get_script ctxt source >>=? (function | No_script -> assert false | Script { storage = { storage } } -> - parse_untagged_data ctxt storage_type storage >>=? fun sto -> + parse_data ctxt storage_type storage >>=? fun sto -> logged_return (Item (v, Item (sto, Empty)), qta - 1, ctxt)) end | Create_account, @@ -457,7 +457,7 @@ let rec interp Item (Lam (_, code), Item (init, rest)))))) -> let code, storage = { code; arg_type = unparse_ty p; ret_type = unparse_ty r; storage_type = unparse_ty g }, - { storage = unparse_untagged_data g init; storage_type = unparse_ty g } in + { storage = unparse_data g init; storage_type = unparse_ty g } in let storage_fee = Script.storage_cost storage in let code_fee = Script.code_cost code in Lwt.return Tez.(code_fee +? storage_fee) >>=? fun script_fee -> @@ -484,7 +484,7 @@ let rec interp let res = Ed25519.check_signature key signature message in logged_return (Item (res, rest), qta - 1, ctxt) | H ty, Item (v, rest) -> - let hash = Script.hash_expr (unparse_untagged_data ty v) in + let hash = Script.hash_expr (unparse_data ty v) in logged_return (Item (hash, rest), qta - 1, ctxt) | Steps_to_quota, rest -> let steps = Script_int.of_int64 Uint32 (Int64.of_int qta) in @@ -514,13 +514,13 @@ and execute ?log orig source ctxt storage script amount arg qta = let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in parse_lambda ctxt arg_type_full ret_type_full code >>=? fun lambda -> - parse_untagged_data ctxt arg_type arg >>=? fun arg -> - parse_untagged_data ctxt storage_type storage >>=? fun storage -> + parse_data ctxt arg_type arg >>=? fun arg -> + parse_data ctxt storage_type storage >>=? fun storage -> interp ?log qta orig source amount ctxt lambda ((amount, arg), storage) >>=? fun (ret, qta, ctxt) -> let ret, storage = ret in - return (unparse_untagged_data storage_type storage, - unparse_untagged_data ret_type ret, + return (unparse_data storage_type storage, + unparse_data ret_type ret, qta, ctxt) let trace orig source ctxt storage script amount arg qta = diff --git a/src/proto/bootstrap/script_ir_translator.ml b/src/proto/bootstrap/script_ir_translator.ml index f360e6f47..272c38213 100644 --- a/src/proto/bootstrap/script_ir_translator.ml +++ b/src/proto/bootstrap/script_ir_translator.ml @@ -441,190 +441,7 @@ let comparable_ty_of_ty | Timestamp_t -> ok Timestamp_key | ty -> error (Incomparable_type (Ty ty)) -type ex_tagged_data = Ex : 'a ty * 'a -> ex_tagged_data - -let rec parse_tagged_data - : context -> Script.expr -> ex_tagged_data tzresult Lwt.t - = fun ctxt script_data -> - match script_data with - | Prim (_, "Unit", []) -> - return @@ Ex (Unit_t, ()) - | Prim (loc, "Unit", l) -> - fail @@ Invalid_arity (loc, Constant, "Unit", 0, List.length l) - | String (_, v) -> - return @@ Ex (String_t, v) - | Prim (_, "String", [ arg ]) -> - parse_untagged_data ctxt String_t arg >>=? fun v -> - return @@ Ex (String_t, v) - | Prim (loc, "String", l) -> - fail @@ Invalid_arity (loc, Constant, "String", 1, List.length l) - | Prim (_, "True", []) -> - return @@ Ex (Bool_t, true) - | Prim (loc, "True", l) -> - fail @@ Invalid_arity (loc, Constant, "True", 0, List.length l) - | Prim (_, "False", []) -> - return @@ Ex (Bool_t, false) - | Prim (loc, "False", l) -> - fail @@ Invalid_arity (loc, Constant, "False", 0, List.length l) - | Prim (_, "Bool", [ arg ]) -> - parse_untagged_data ctxt Bool_t arg >>=? fun v -> - return @@ Ex (Bool_t, v) - | Prim (loc, "Bool", l) -> - fail @@ Invalid_arity (loc, Constant, "Bool", 1, List.length l) - | Prim (_, "Timestamp", [ arg ]) -> - parse_untagged_data ctxt Timestamp_t arg >>=? fun v -> - return @@ Ex (Timestamp_t, v) - | Prim (loc, "Timestamp", l) -> - fail @@ Invalid_arity (loc, Constant, "Timestamp", 1, List.length l) - | Prim (_, "Signature", [ arg ]) -> - parse_untagged_data ctxt Signature_t arg >>=? fun v -> - return @@ Ex (Signature_t, v) - | Prim (loc, "Signature", l) -> - fail @@ Invalid_arity (loc, Constant, "Signature", 1, List.length l) - | Prim (_, "Tez", [ arg ]) -> - parse_untagged_data ctxt Tez_t arg >>=? fun v -> - return @@ Ex (Tez_t, v) - | Prim (loc, "Tez", l) -> - fail @@ Invalid_arity (loc, Constant, "Tez", 1, List.length l) - | Prim (_, "Key", [ arg ]) -> - parse_untagged_data ctxt Key_t arg >>=? fun v -> - return @@ Ex (Key_t, v) - | Prim (loc, "Key", l) -> - fail @@ Invalid_arity (loc, Constant, "Key", 1, List.length l) - | Prim (_, "Int8", [ arg ]) -> - parse_untagged_data ctxt (Int_t Int8) arg >>=? fun v -> - return @@ Ex (Int_t Int8, v) - | Prim (loc, "Int8", l) -> - fail @@ Invalid_arity (loc, Constant, "Int8", 1, List.length l) - | Prim (_, "Int16", [ arg ]) -> - parse_untagged_data ctxt (Int_t Int16) arg >>=? fun v -> - return @@ Ex (Int_t Int16, v) - | Prim (loc, "Int16", l) -> - fail @@ Invalid_arity (loc, Constant, "Int16", 1, List.length l) - | Prim (_, "Int32", [ arg ]) -> - parse_untagged_data ctxt (Int_t Int32) arg >>=? fun v -> - return @@ Ex (Int_t Int32, v) - | Prim (loc, "Int32", l) -> - fail @@ Invalid_arity (loc, Constant, "Int32", 1, List.length l) - | Prim (_, "Int64", [ arg ]) -> - parse_untagged_data ctxt (Int_t Int64) arg >>=? fun v -> - return @@ Ex (Int_t Int64, v) - | Prim (loc, "Int64", l) -> - fail @@ Invalid_arity (loc, Constant, "Int64", 1, List.length l) - | Prim (_, "Uint8", [ arg ]) -> - parse_untagged_data ctxt (Int_t Uint8) arg >>=? fun v -> - return @@ Ex (Int_t Uint8, v) - | Prim (loc, "Uint8", l) -> - fail @@ Invalid_arity (loc, Constant, "Uint8", 1, List.length l) - | Prim (_, "Uint16", [ arg ]) -> - parse_untagged_data ctxt (Int_t Uint16) arg >>=? fun v -> - return @@ Ex (Int_t Uint16, v) - | Prim (loc, "Uint16", l) -> - fail @@ Invalid_arity (loc, Constant, "Uint16", 1, List.length l) - | Prim (_, "Uint32", [ arg ]) -> - parse_untagged_data ctxt (Int_t Uint32) arg >>=? fun v -> - return @@ Ex (Int_t Uint32, v) - | Prim (loc, "Uint32", l) -> - fail @@ Invalid_arity (loc, Constant, "Uint32", 1, List.length l) - | Prim (_, "Uint64", [ arg ]) -> - parse_untagged_data ctxt (Int_t Uint64) arg >>=? fun v -> - return @@ Ex (Int_t Uint64, v) - | Prim (loc, "Uint64", l) -> - fail @@ Invalid_arity (loc, Constant, "Uint64", 1, List.length l) - | Prim (_, "Left", [ l; tr ]) -> - parse_ty tr >>=? fun (Ex tr) -> - parse_tagged_data ctxt l >>=? fun (Ex (tl, l)) -> - return @@ Ex (Union_t (tl, tr), L l) - | Prim (loc, "Left", l) -> - fail @@ Invalid_arity (loc, Constant, "Left", 2, List.length l) - | Prim (_, "Right", [ tl; r ]) -> - parse_ty tl >>=? fun (Ex tl) -> - parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> - return @@ Ex (Union_t (tl, tr), R r) - | Prim (loc, "Right", l) -> - fail @@ Invalid_arity (loc, Constant, "Right", 2, List.length l) - | Prim (_, "Or", [ tl; tr; arg ]) -> - parse_ty tl >>=? fun (Ex tl) -> - parse_ty tr >>=? fun (Ex tr) -> - parse_untagged_data ctxt (Union_t (tl, tr)) arg >>=? fun v -> - return @@ Ex (Union_t (tl, tr), v) - | Prim (loc, "Or", l) -> - fail @@ Invalid_arity (loc, Constant, "Or", 3, List.length l) - | Prim (_, "Some", [ r ]) -> - parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> - return @@ Ex (Option_t tr, Some r) - | Prim (_, "Some", [ tr; r ]) -> - parse_ty tr >>=? fun (Ex tr) -> - parse_untagged_data ctxt tr r >>=? fun r -> - return @@ Ex (Option_t tr, Some r) - | Prim (loc, "Some", l) -> - fail @@ Invalid_arity (loc, Constant, "Some", 1, List.length l) - | Prim (_, "None", [ tr ]) -> - parse_ty tr >>=? fun (Ex tr) -> - return @@ Ex (Option_t tr, None) - | Prim (loc, "None", l) -> - fail @@ Invalid_arity (loc, Constant, "None", 1, List.length l) - | Prim (_, "Option", [ tr; r ]) -> - parse_ty tr >>=? fun (Ex tr) -> - parse_untagged_data ctxt (Option_t tr) r >>=? fun r -> - return @@ Ex (Option_t tr, r) - | Prim (loc, "Option", l) -> - fail @@ Invalid_arity (loc, Constant, "Option", 2, List.length l) - | Prim (_, "Pair", [ tl; tr; l; r ]) -> - parse_ty tl >>=? fun (Ex tl) -> - parse_ty tr >>=? fun (Ex tr) -> - parse_untagged_data ctxt tl l >>=? fun l -> - parse_untagged_data ctxt tr r >>=? fun r -> - return @@ Ex (Pair_t (tl, tr), (l, r)) - | Prim (_, "Pair", [ l; r ]) -> - parse_tagged_data ctxt l >>=? fun (Ex (tl, l)) -> - parse_tagged_data ctxt r >>=? fun (Ex (tr, r)) -> - return @@ Ex (Pair_t (tl, tr), (l, r)) - | Prim (loc, "Pair", l) -> - fail @@ Invalid_arity (loc, Constant, "Pair", 4, List.length l) - | Prim (loc, "List", t :: items) -> - parse_ty t >>=? fun (Ex t) -> - parse_untagged_data ctxt - (List_t t) (Prim (loc, "List", items)) >>=? fun l -> - return @@ Ex (List_t t, l) - | Prim (loc, "List", l) -> - fail @@ Invalid_arity (loc, Constant, "List", 1, List.length l) - | Prim (loc, "Set", t :: items) -> - parse_comparable_ty t >>=? fun (Ex t) -> - parse_untagged_data ctxt - (Set_t t) (Prim (loc, "Set", items)) >>=? fun l -> - return @@ Ex (Set_t t, l) - | Prim (loc, "Set", l) -> - fail @@ Invalid_arity (loc, Constant, "Set", 1, List.length l) - | Prim (loc, "Map", kt :: vt :: items) -> - parse_comparable_ty kt >>=? fun (Ex kt) -> - parse_ty vt >>=? fun (Ex vt) -> - parse_untagged_data ctxt - (Map_t (kt, vt)) (Prim (loc, "Map", items)) >>=? fun l -> - return @@ Ex (Map_t (kt, vt), l) - | Prim (loc, "Map", l) -> - fail @@ Invalid_arity (loc, Constant, "Map", 2, List.length l) - | Prim (_, "Contract", [ at; rt; c ]) -> - parse_ty at >>=? fun (Ex at) -> - parse_ty rt >>=? fun (Ex rt) -> - parse_untagged_data ctxt (Contract_t (at, rt)) c >>=? fun l -> - return @@ Ex (Contract_t (at, rt), l) - | Prim (loc, "Contract", l) -> - fail @@ Invalid_arity (loc, Constant, "Contract", 3, List.length l) - | Prim (loc, "Lambda", [ at ; rt ; code ]) -> - expect_sequence_parameter loc Constant "Lambda" 2 code >>=? fun () -> - parse_ty at >>=? fun (Ex at) -> - parse_ty rt >>=? fun (Ex rt) -> - parse_untagged_data ctxt (Lambda_t (at, rt)) code >>=? fun l -> - return @@ Ex (Lambda_t (at, rt), l) - | Prim (loc, "Lambda", l) -> - fail @@ Invalid_arity (loc, Constant, "Lambda", 3, List.length l) - | Prim (loc, name, _) -> - fail @@ Invalid_primitive (loc, Constant, name) - | Seq (loc, _) | Int (loc, _) -> - fail @@ Invalid_expression_kind loc - -and parse_untagged_data +let rec parse_data : type a. context -> a ty -> Script.expr -> a tzresult Lwt.t = fun ctxt ty script_data -> match ty, script_data with @@ -704,8 +521,8 @@ and parse_untagged_data fail @@ Invalid_constant (loc, "contract") (* Pairs *) | Pair_t (ta, tb), Prim (_, "Pair", [ va; vb ]) -> - parse_untagged_data ctxt ta va >>=? fun va -> - parse_untagged_data ctxt tb vb >>=? fun vb -> + parse_data ctxt ta va >>=? fun va -> + parse_data ctxt tb vb >>=? fun vb -> return (va, vb) | Pair_t _, Prim (loc, "Pair", l) -> fail @@ Invalid_arity (loc, Constant, "Pair", 2, List.length l) @@ -713,12 +530,12 @@ and parse_untagged_data fail @@ Invalid_constant (loc, "pair") (* Unions *) | Union_t (tl, _), Prim (_, "Left", [ v ]) -> - parse_untagged_data ctxt tl v >>=? fun v -> + parse_data ctxt tl v >>=? fun v -> return (L v) | Union_t _, Prim (loc, "Left", l) -> fail @@ Invalid_arity (loc, Constant, "Left", 1, List.length l) | Union_t (_, tr), Prim (_, "Right", [ v ]) -> - parse_untagged_data ctxt tr v >>=? fun v -> + parse_data ctxt tr v >>=? fun v -> return (R v) | Union_t _, Prim (loc, "Right", l) -> fail @@ Invalid_arity (loc, Constant, "Right", 1, List.length l) @@ -731,7 +548,7 @@ and parse_untagged_data fail @@ Invalid_constant (loc, "lambda") (* Options *) | Option_t t, Prim (_, "Some", [ v ]) -> - parse_untagged_data ctxt t v >>=? fun v -> + parse_data ctxt t v >>=? fun v -> return (Some v) | Option_t _, Prim (loc, "Some", l) -> fail @@ Invalid_arity (loc, Constant, "Some", 1, List.length l) @@ -745,7 +562,7 @@ and parse_untagged_data | List_t t, Prim (_, "List", vs) -> fold_left_s (fun rest v -> - parse_untagged_data ctxt t v >>=? fun v -> + parse_data ctxt t v >>=? fun v -> return (v :: rest)) [] vs | List_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> @@ -754,7 +571,7 @@ and parse_untagged_data | Set_t t, Prim (_, "Set", vs) -> fold_left_s (fun acc v -> - parse_untagged_comparable_data ctxt t v >>=? fun v -> + parse_comparable_data ctxt t v >>=? fun v -> return (set_update v true acc)) (empty_set t) vs | Set_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> @@ -764,8 +581,8 @@ and parse_untagged_data fold_left_s (fun acc -> function | Prim (_, "Item", [ k; v ]) -> - parse_untagged_comparable_data ctxt tk k >>=? fun k -> - parse_untagged_data ctxt tv v >>=? fun v -> + parse_comparable_data ctxt tk k >>=? fun k -> + parse_data ctxt tv v >>=? fun v -> return (map_update k (Some v) acc) | Prim (loc, "Item", l) -> fail @@ Invalid_arity (loc, Constant, "Item", 2, List.length l) @@ -775,10 +592,10 @@ and parse_untagged_data | Map_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) -> fail @@ Invalid_constant (loc, "map") -and parse_untagged_comparable_data +and parse_comparable_data : type a. context -> a comparable_ty -> Script.expr -> a tzresult Lwt.t = fun ctxt ty script_data -> - parse_untagged_data ctxt (ty_of_comparable_ty ty) script_data + parse_data ctxt (ty_of_comparable_ty ty) script_data and parse_lambda : type arg ret storage. context -> @@ -817,9 +634,10 @@ and parse_instr | Prim (loc, "SWAP", []), Item_t (v, Item_t (w, rest)) -> return (typed loc (Swap, Item_t (w, Item_t (v, rest)))) - | Prim (loc, "PUSH", [ td ]), + | Prim (loc, "PUSH", [ t ; d ]), stack -> - parse_tagged_data ctxt td >>=? fun (Ex (t, v)) -> + parse_ty t >>=? fun (Ex t) -> + parse_data ctxt t d >>=? fun v -> return (typed loc (Const v, Item_t (t, stack))) (* options *) | Prim (loc, "SOME", []), @@ -1497,7 +1315,7 @@ let rec unparse_ty let tr = unparse_ty utr in Prim (-1, "map", [ ta; tr ]) -let rec unparse_untagged_data +let rec unparse_data : type a. a ty -> a -> Script.expr = fun ty a -> match ty, a with | Unit_t, () -> @@ -1524,29 +1342,29 @@ let rec unparse_untagged_data | Key_t, k -> String (-1, Ed25519.Public_key_hash.to_b48check k) | Pair_t (tl, tr), (l, r) -> - let l = unparse_untagged_data tl l in - let r = unparse_untagged_data tr r in + let l = unparse_data tl l in + let r = unparse_data tr r in Prim (-1, "Pair", [ l; r ]) | Union_t (tl, _), L l -> - let l = unparse_untagged_data tl l in + let l = unparse_data tl l in Prim (-1, "Left", [ l ]) | Union_t (_, tr), R r -> - let r = unparse_untagged_data tr r in + let r = unparse_data tr r in Prim (-1, "Right", [ r ]) | Option_t t, Some v -> - let v = unparse_untagged_data t v in + let v = unparse_data t v in Prim (-1, "Some", [ v ]) | Option_t _, None -> Prim (-1, "None", []) | List_t t, items -> - let items = List.map (unparse_untagged_data t) items in + let items = List.map (unparse_data t) items in Prim (-1, "List", items) | Set_t t, set -> let t = ty_of_comparable_ty t in let items = set_fold (fun item acc -> - unparse_untagged_data t item :: acc ) + unparse_data t item :: acc ) set [] in Prim (-1, "Set", items) | Map_t (kt, vt), map -> @@ -1554,92 +1372,14 @@ let rec unparse_untagged_data let items = map_fold (fun k v acc -> Prim (-1, "Item", - [ unparse_untagged_data kt k; - unparse_untagged_data vt v ]) + [ unparse_data kt k; + unparse_data vt v ]) :: acc) map [] in Prim (-1, "Map", items) | Lambda_t _, Lam (_, original_code) -> original_code -let rec unparse_tagged_data - : type a. a ty -> a -> Script.expr - = fun ty a -> match ty, a with - | Unit_t, () -> - Prim (-1, "Unit", []) - | Int_t k, v -> - Prim (-1, string_of_int_kind k, [ String (-1, Int64.to_string (to_int64 k v))]) - | String_t, s -> - Prim (-1, "String", [ String (-1, s) ]) - | Bool_t, true -> - Prim (-1, "Bool", [ Prim (-1, "True", []) ]) - | Bool_t, false -> - Prim (-1, "Bool", [ Prim (-1, "False", []) ]) - | Timestamp_t, t -> - Prim (-1, "Timestamp", [ String (-1, Timestamp.to_notation t) ]) - | Contract_t (ta, tr), (_, _, c) -> - let ta = unparse_ty ta in - let tr = unparse_ty tr in - Prim (-1, "Contract", [ ta; tr; String (-1, Contract.to_b48check c) ]) - | Signature_t, s -> - let text = - Hex_encode.hex_encode - (MBytes.to_string (Data_encoding.Binary.to_bytes Ed25519.signature_encoding s)) in - Prim (-1, "Signature", [ String (-1, text) ]) - | Tez_t, v -> - Prim (-1, "Tez", [ String (-1, Tez.to_string v) ]) - | Key_t, k -> - Prim (-1, "Key", [ String (-1, Ed25519.Public_key_hash.to_b48check k)]) - | Pair_t (tl, tr), (l, r) -> - let l = unparse_untagged_data tl l in - let r = unparse_untagged_data tr r in - let tl = unparse_ty tl in - let tr = unparse_ty tr in - Prim (-1, "Pair", [ tl; tr; l; r ]) - | Union_t (tl, tr), L l -> - let l = unparse_tagged_data tl l in - let tr = unparse_ty tr in - Prim (-1, "Left", [ l; tr ]) - | Union_t (tl, tr), R r -> - let r = unparse_tagged_data tr r in - let tl = unparse_ty tl in - Prim (-1, "Right", [ tl; r ]) - | Option_t t, Some v -> - let v = unparse_tagged_data t v in - Prim (-1, "Some", [ v ]) - | Option_t t, None -> - let t = unparse_ty t in - Prim (-1, "None", [ t ]) - | List_t t, items -> - let items = List.map (unparse_untagged_data t) items in - let t = unparse_ty t in - Prim (-1, "List", t :: items) - | Set_t t, set -> - let t = ty_of_comparable_ty t in - let items = - set_fold - (fun item acc -> - unparse_untagged_data t item :: acc ) - set [] in - let t = unparse_ty t in - Prim (-1, "Set", t :: items) - | Map_t (kt, vt), map -> - let kt = ty_of_comparable_ty kt in - let items = - map_fold (fun k v acc -> - Prim (-1, "Item", - [ unparse_untagged_data kt k; - unparse_untagged_data vt v ]) - :: acc) - map [] in - let kt = unparse_ty kt in - let vt = unparse_ty vt in - Prim (-1, "Map", kt :: vt :: items) - | Lambda_t (ta, tr), Lam (_, original_code) -> - let ta = unparse_ty ta in - let tr = unparse_ty tr in - Prim (-1, "Lambda", [ ta; tr; original_code ]) - type ex_script = Ex : ('a, 'b, 'c) script -> ex_script let parse_script @@ -1650,7 +1390,7 @@ let parse_script parse_ty storage_type >>=? fun (Ex storage_type) -> let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in - parse_untagged_data ctxt storage_type storage >>=? fun storage -> + parse_data ctxt storage_type storage >>=? fun storage -> parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun code -> return (Ex { code; arg_type; ret_type; storage; storage_type }) @@ -1720,15 +1460,9 @@ let typecheck_code >>=? fun (Lam (descr,_)) -> return (type_map descr) -let typecheck_tagged_data - : context -> Script.expr -> unit tzresult Lwt.t - = fun ctxt data -> - parse_tagged_data ctxt data >>=? fun (Ex _) -> - return () - -let typecheck_untagged_data +let typecheck_data : context -> Script.expr * Script.expr -> unit tzresult Lwt.t = fun ctxt (data, exp_ty) -> parse_ty exp_ty >>=? fun (Ex exp_ty) -> - parse_untagged_data ctxt exp_ty data >>=? fun _ -> + parse_data ctxt exp_ty data >>=? fun _ -> return () diff --git a/src/proto/bootstrap/services.ml b/src/proto/bootstrap/services.ml index 13c085581..15607e5ee 100644 --- a/src/proto/bootstrap/services.ml +++ b/src/proto/bootstrap/services.ml @@ -368,27 +368,19 @@ module Helpers = struct ~output: (wrap_tzerror Script_ir_translator.type_map_enc) RPC.Path.(custom_root / "helpers" / "typecheck_code") - let typecheck_tagged_data custom_root = + let typecheck_data custom_root = RPC.service - ~description: "Check that some tagged data expression is well formed \ - and well typed in the current context" - ~input: (obj1 (req "data" Script.expr_encoding)) - ~output: (wrap_tzerror empty) - RPC.Path.(custom_root / "helpers" / "typecheck_tagged_data") - - let typecheck_untagged_data custom_root = - RPC.service - ~description: "Check that some untagged data expression is well formed \ + ~description: "Check that some data expression is well formed \ and of a given type in the current context" ~input: (obj2 (req "data" Script.expr_encoding) (req "type" Script.expr_encoding)) ~output: (wrap_tzerror empty) - RPC.Path.(custom_root / "helpers" / "typecheck_untagged_data") + RPC.Path.(custom_root / "helpers" / "typecheck_data") let hash_data custom_root = RPC.service - ~description: "Computes the hash of some (untagged) data expression \ + ~description: "Computes the hash of some data expression \ using the same algorithm as script instruction H" ~input: (obj1 (req "data" Script.expr_encoding)) ~output: (wrap_tzerror @@ diff --git a/src/proto/bootstrap/services_registration.ml b/src/proto/bootstrap/services_registration.ml index ff2fc881b..606f861f7 100644 --- a/src/proto/bootstrap/services_registration.ml +++ b/src/proto/bootstrap/services_registration.ml @@ -226,12 +226,8 @@ let () = Script_ir_translator.typecheck_code let () = - register1 Services.Helpers.typecheck_tagged_data - Script_ir_translator.typecheck_tagged_data - -let () = - register1 Services.Helpers.typecheck_untagged_data - Script_ir_translator.typecheck_untagged_data + register1 Services.Helpers.typecheck_data + Script_ir_translator.typecheck_data let () = register1 Services.Helpers.hash_data diff --git a/test/scripts/hardlimit.tez b/test/scripts/hardlimit.tez index 481d692ce..8099fd538 100644 --- a/test/scripts/hardlimit.tez +++ b/test/scripts/hardlimit.tez @@ -1,8 +1,8 @@ parameter unit code { # This contract stop to accept transactions after N incoming transactions - CDR ; PUSH (Uint32 1) ; SWAP ; SUB ; - DUP ; PUSH (Uint32 0) ; COMPARE ; EQ ; IF { FAIL } {} ; + CDR ; PUSH uint32 1 ; SWAP ; SUB ; + DUP ; PUSH uint32 0 ; COMPARE ; EQ ; IF { FAIL } {} ; UNIT ; PAIR } return unit storage uint32 \ No newline at end of file