balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Michelson: get rid of tagged data notation.

Browse Source
This commit is contained in:
Benjamin Canou 2017-01-11 17:42:54 +01:00
parent 26e1adc143
commit 507c46bbcb
9 changed files with 202 additions and 511 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/client/embedded/bootstrap/client_proto_programs.ml
View File

@ -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"

7
src/client/embedded/bootstrap/client_proto_rpcs.ml
View File

@ -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

5
src/client/embedded/bootstrap/client_proto_rpcs.mli
View File

@ -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:

309
src/proto/bootstrap/docs/language.md
View File

@ -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 <untagged data> <untagged data>
| Left <untagged data>
| Right <untagged data>
| Some <untagged data>
| Pair <data> <data>
| Left <data>
| Right <data>
| Some <data>
| None
| List <untagged data> ...
| Set <untagged data> ...
| Map (Item <untagged data> <untagged data>) ...
| List <data> ...
| Set <data> ...
| Map (Item <data> <data>) ...
| instruction
<instruction> ::=
| { <instruction> ... }
| DROP
| DUP
| SWAP
| PUSH <tagged data>
| PUSH <type> <data>
| SOME
| NONE <type>
| IF_NONE { <instruction> ... } { <instruction> ... }

30
src/proto/bootstrap/script_interpreter.ml
View File

@ -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 =

322
src/proto/bootstrap/script_ir_translator.ml
View File

@ -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 ()

16
src/proto/bootstrap/services.ml
View File

@ -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 @@

8
src/proto/bootstrap/services_registration.ml
View File

@ -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

4
test/scripts/hardlimit.tez
View File

@ -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