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

Proto: drop floats in the contract language.

Browse Source
This commit is contained in:
Benjamin Canou 2016-11-08 19:31:01 +01:00
parent b4b3aece97
commit f284714fba
11 changed files with 35 additions and 364 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -69,7 +69,6 @@ let rec print_ir ppf node =
match node with
| String (_, s) -> Format.fprintf ppf "%S" s
| Int (_, s) -> Format.fprintf ppf "%s" s
| Float (_, s) -> Format.fprintf ppf "%s" s
| Seq (_, [ one ]) -> print_ir ppf one
| Seq (_, []) -> Format.fprintf ppf "{}" ;
| Seq (_, seq) ->

24
src/client/embedded/bootstrap/concrete_lexer.mll
View File

@ -73,22 +73,6 @@ let char_for_hexadecimal_code lexbuf i =
in
char_of_int (val1 * 16 + val2)
(* Remove underscores from float literals *)
let remove_underscores s =
let s = Bytes.of_string s in
let l = Bytes.length s in
let rec remove src dst =
if Compare.Int.(src >= l) then
if Compare.Int.(dst >= l) then s else Bytes.sub s 0 dst
else
match Bytes.get s src with
'_' -> remove (src + 1) dst
| c -> Bytes.set s dst c; remove (src + 1) (dst + 1)
in Bytes.to_string (remove 0 0)
(** Lexer state *)
type state = {
@ -234,11 +218,6 @@ let bin_literal =
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
let int_literal =
'-' ? ( decimal_literal | hex_literal | oct_literal | bin_literal)
let float_literal =
'-' ?
['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
rule indent_tokens st nl = parse
@ -332,9 +311,6 @@ and raw_token st = parse
| int_literal
{ INT (Lexing.lexeme lexbuf) }
| float_literal
{ FLOAT (remove_underscores (Lexing.lexeme lexbuf)) }
| "\""
{ reset_string_buffer st;
let string_start = lexbuf.Lexing.lex_start_p in

6
src/client/embedded/bootstrap/concrete_parser.mly
View File

@ -9,12 +9,11 @@
%token RPAREN
%token SEMICOLON
%token <string> FLOAT
%token <string> INT
%token <string> PRIM
%token <string> STRING
%left PRIM INT FLOAT LPAREN LBRACE STRING
%left PRIM INT LPAREN LBRACE STRING
%left apply
%start <Script_located_ir.node list> tree
@ -127,7 +126,7 @@ let expand = function
let apply node arg =
match node with
| Prim (loc, n, args) -> Prim (loc, n, args @ [arg])
| Int _ | Float _ | String _ | Seq _ as _node ->
| Int _ | String _ | Seq _ as _node ->
raise (Invalid_application (node_location arg))
let rec apply_seq node = function
@ -166,7 +165,6 @@ line_node:
| LBRACE nodes = nodes RBRACE { Seq (pos $startpos $endpos, nodes) }
| prim = PRIM { Prim (pos $startpos $endpos, prim, []) }
| i = INT { Int (pos $startpos $endpos, i) }
| f = FLOAT { Float (pos $startpos $endpos, f) }
| s = STRING { String (pos $startpos $endpos, s) }
%%

4
src/client/embedded/bootstrap/script_located_ir.ml
View File

@ -15,14 +15,12 @@ type location =
type node =
| Int of location * string
| Float of location * string
| String of location * string
| Prim of location * string * node list
| Seq of location * node list
let node_location = function
| Int (loc, _)
| Float (loc, _)
| String (loc, _)
| Prim (loc, _, _)
| Seq (loc, _) -> loc
@ -57,8 +55,6 @@ let strip_locations root =
match l with
| Int (_, v) ->
Script.Int (id, v)
| Float (_, v) ->
Script.Float (id, v)
| String (_, v) ->
Script.String (id, v)
| Seq (_, seq) ->

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

@ -32,7 +32,7 @@ I - Type system
The types `T` of values in the stack are written using notations
* `bool`, `string`, `void`, `u?int{8|16|32|64}`, `float`,
* `bool`, `string`, `void`, `u?int{8|16|32|64}`,
the core primitive types,
* `identifier` for a primitive data-type,
* `T identifier` for a parametric data-type with one parameter type `T`,
@ -94,7 +94,6 @@ the form `variable = constant, ...`.
The constants are of one of the following forms.
* integers with their sign and size, e.g. `(Uint8 3)`,
* floats in libc-style notation, e.g. `(Float 4.5e2)`,
* `Void`, the unique value of type `void`
* booleans `True` and `False`,
* string literals, as in `(String "contents")`,
@ -274,7 +273,7 @@ combinators, and also for branching.
IV - Data types
---------------
* `bool`, `string`, `void`, `u?int{8|16|32|64}`, `float`:
* `bool`, `string`, `void`, `u?int{8|16|32|64}`:
The core primitive types.
* `list 'a`:
@ -507,129 +506,6 @@ Bitwise logical operators are also available on unsigned integers.
:: t : t : 'S -> int64 : 'S where t in uint{8|16|32|64}
### Operations on Floats
The float type uses double precision IEEE754 semantics, including NaN
and infinite values.
* `ADD`
:: float : float : 'S -> float : 'S
> ADD ; C / x : y : S => C / (x + y) : S
* `SUB`
:: float : float : 'S -> float : 'S
> SUB ; C / x : y : S => C / (x - y) : S
* `MUL`
:: float : float : 'S -> float : 'S
> MUL ; C / x : y : S => C / (x * y) : S
* `DIV`
:: float : float : 'S -> float : 'S
> DIV ; C / x : y : S => C / (x / y) : S
* `MOD`
:: float : float : 'S -> float : 'S
> MOD ; C / x : y : S => C / (fmod (x, y)) : S
* `ABS`
:: float : 'S -> float : 'S
> ABS ; C / x : S => C / (abs (x)) : S
* `NEG`
:: float : 'S -> float : 'S
> NEG ; C / x : S => C / (-x) : S
* `FLOOR`
:: float : 'S -> float : 'S
> FLOOR ; C / x : S => C / (floor (x)) : S
* `CEIL`
:: float : 'S -> float : 'S
> CEIL ; C / x : S => C / (ceil (x)) : S
* `INF`
:: 'S -> float : 'S
> INF ; C / S => C / +Inf : S
* `NAN`
:: 'S -> float : 'S
> NAN ; C / S => C / NaN : S
* `ISNAN`
:: float : 'S -> bool : 'S
> ISNAN ; C / NaN : S => C / true : S
> ISNAN ; C / _ : S => C / false : S
* `NANAN`
:: float : 'S -> 'S
> NANAN ; C / NaN : S => [FAIL]
> NANAN ; C / _ : S => C / S
* `CAST float`:
Conversion from integers.
:: t_from : 'S -> float : 'S where t_from in u?int{8|16|32|64}
> CAST float ; C / x : S => C / float (x) : S
* `CAST t_to` where `t_to in u?int{8|16|32|64}`:
Conversion to integers.
:: float : 'S -> t_to : 'S
> CAST t_to ; C / NaN : S => C / t_to (0) : S
> CAST t_to ; C / +/-Inf : S => C / t_to (0) : S
> CAST t_to ; C / x : S => C / t_to (floor (x)) : S
* `CHECKED_CAST float`:
Conversion from integers with overflow checking.
:: t_from : 'S -> float : 'S where t_from in u?int{8|16|32|64}
> CHECKED_CAST float ; C / x : S => [FAIL] on overflow
> CHECKED_CAST float ; C / x : S => C / float (x) : S
* `CHECKED_CAST t_to` where `t_to in u?int{8|16|32|64}`:
Conversion to integers with overflow checking.
:: float : 'S -> t_to : 'S
> CHECKED_CAST t_to ; C / x : S => [FAIL] on overflow or NaN
> CHECKED_CAST t_to ; C / x : S => C / t_to (floor (x)) : S
* `COMPARE`:
IEEE754 comparison
:: float : float : 'S -> int64 : 'S
### Operations on strings
Strings are mostly used for naming things without having to rely on
@ -1111,14 +987,11 @@ parsing policy is described just after.
### Constants
There are three kinds of constants:
There are two kinds of constants:
1. Integers in decimal (no prefix), hexadecimal (0x prefix), octal
(0o prefix) or binary (0b prefix).
2. Floating point IEEE754 doubles in libc-style notation, with a
mandatory period character. (`3` is an `int` but `3.` is a
`float`).
3. Strings with usual escapes `\n`, `\t`, `\b`, `\r`, `\\`, `\"`.
2. Strings with usual escapes `\n`, `\t`, `\b`, `\r`, `\\`, `\"`.
Strings are encoding agnostic sequences of bytes. Non printable
characters can be escaped by 3 digits decimal codes `\ddd` or
2 digit hexadecimal codes `\xHH`.
@ -1258,8 +1131,6 @@ Capitalised.
Int8 1
Float 3.5e12
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
@ -1675,7 +1546,6 @@ X - Full grammar
<tagged data> ::=
| <string constant>
| <float constant>
| Int8 <int constant>
| Int16 <int constant>
| Int32 <int constant>
@ -1710,7 +1580,6 @@ X - Full grammar
<untagged data> ::=
| <int constant>
| <string constant>
| <float constant>
| <timestamp string constant>
| <signature string constant>
| <key string constant>
@ -1820,7 +1689,6 @@ X - Full grammar
| uint64
| void
| string
| float
| tez
| bool
| key
@ -1845,7 +1713,6 @@ X - Full grammar
| uint32
| uint64
| string
| float
| tez
| bool
| key
@ -1880,9 +1747,9 @@ The language is implemented in OCaml as follows:
interpreting the If instruction.
* The input, untyped internal representation is an OCaml ADT with
the only 5 grammar constructions: `String`, `Float`, `Int`, `Seq`
and `Prim`. It is the target language for the parser, since not
all parsable programs are well typed, and thus could simply not be
the only 5 grammar constructions: `String`, `Int`, `Seq` and
`Prim`. It is the target language for the parser, since not all
parsable programs are well typed, and thus could simply not be
constructed using the GADT.
* The typechecker is a simple function that recognizes the abstract

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

@ -65,16 +65,11 @@ type 'tys stack =
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
| Empty : end_of_stack stack
let is_nan x = match classify_float x with
| FP_nan -> true
| _ -> false
let eq_comparable
: type a. a comparable_ty -> a -> a -> bool
= fun kind x v -> match kind with
| String_key -> Compare.String.(x = v)
| Bool_key -> Compare.Bool.(x = v)
| Float_key -> Compare.Float.(x = v)
| Tez_key -> Tez.(x = v)
| Key_key -> Ed25519.Public_key_hash.(equal x v)
| Int_key kind -> Script_int.(equal kind x v)
@ -235,22 +230,12 @@ let rec interp
r := v ;
return (rest, qta - 1, ctxt)
(* timestamp operations *)
| Add_period_to_timestamp, Item (p, Item (t, rest)) ->
Lwt.return
(Period.of_seconds (Int64.of_float p) >>? fun p ->
Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt))
| Add_seconds_to_timestamp (kind, _pos), Item (n, Item (t, rest)) ->
let n = Script_int.to_int64 kind n in
Lwt.return
(Period.of_seconds n >>? fun p ->
Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt))
| Add_timestamp_to_period, Item (t, Item (p, rest)) ->
Lwt.return
(Period.of_seconds (Int64.of_float p) >>? fun p ->
Timestamp.(t +? p) >>? fun res ->
Ok (Item (res, rest), qta - 1, ctxt))
| Add_timestamp_to_seconds (kind, _pos), Item (t, Item (n, rest)) ->
let n = Script_int.to_int64 kind n in
Lwt.return
@ -273,33 +258,6 @@ let rec interp
| Mul_tez' kind, Item (y, Item (x, rest)) ->
Lwt.return Tez.(x *? Script_int.to_int64 kind y) >>=? fun res ->
return (Item (res, rest), qta - 1, ctxt)
(* float operations *)
| Floor, Item (x, rest) ->
return (Item (floor x, rest), qta - 1, ctxt)
| Ceil, Item (x, rest) ->
return (Item (ceil x, rest), qta - 1, ctxt)
| Inf, rest ->
return (Item (infinity, rest), qta - 1, ctxt)
| NaN, rest ->
return (Item (nan, rest), qta - 1, ctxt)
| IsNaN, Item (x, rest) ->
return (Item (is_nan x, rest), qta - 1, ctxt)
| NaNaN pos, Item (x, rest) ->
if is_nan x then fail (Reject pos) else return (rest, qta - 1, ctxt)
| Abs_float, Item (x, rest) ->
return (Item (abs_float x, rest), qta - 1, ctxt)
| Neg_float, Item (x, rest) ->
return (Item (0. -. x, rest), qta - 1, ctxt)
| Add_float, Item (x, Item (y, rest)) ->
return (Item (x +. y, rest), qta - 1, ctxt)
| Sub_float, Item (x, Item (y, rest)) ->
return (Item (x -. y, rest), qta - 1, ctxt)
| Mul_float, Item (x, Item (y, rest)) ->
return (Item (x *. y, rest), qta - 1, ctxt)
| Div_float, Item (x, Item (y, rest)) ->
return (Item (x /. y, rest), qta - 1, ctxt)
| Mod_float, Item (x, Item (y, rest)) ->
return (Item (mod_float x y, rest), qta - 1, ctxt)
(* boolean operations *)
| Or, Item (x, Item (y, rest)) ->
return (Item (x || y, rest), qta - 1, ctxt)
@ -401,10 +359,6 @@ let rec interp
let cmpres = Compare.String.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt)
| Compare Float_key, Item (a, Item (b, rest)) ->
let cmpres = Compare.Float.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
return (Item (cmpres, rest), qta - 1, ctxt)
| Compare Tez_key, Item (a, Item (b, rest)) ->
let cmpres = Tez.compare a b in
let cmpres = Script_int.of_int64 Int64 (Int64.of_int cmpres) in
@ -453,12 +407,6 @@ let rec interp
end
| Int_of_int (_, kt), Item (v, rest) ->
return (Item (Script_int.cast kt v, rest), qta - 1, ctxt)
| Int_of_float kt, Item (v, rest) ->
let v = Int64.of_float v in
return (Item (Script_int.of_int64 kt v, rest), qta - 1, ctxt)
| Float_of_int kf, Item (v, rest) ->
let v = Int64.to_float (Script_int.to_int64 kf v) in
return (Item (v, rest), qta - 1, ctxt)
(* protocol *)
| Manager, Item ((_, _, contract), rest) ->
Contract.get_manager ctxt contract >>=? fun manager ->

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

@ -71,7 +71,6 @@ let () =
let location = function
| Prim (loc, _, _)
| Float (loc, _)
| Int (loc, _)
| String (loc, _)
| Seq (loc, _) -> loc
@ -132,7 +131,6 @@ let rec ty_eq
record_trace (Inconsistent_types (Ty ta, Ty tb))
| String_t, String_t -> eq ta tb
| Signature_t, Signature_t -> eq ta tb
| Float_t, Float_t -> eq ta tb
| Tez_t, Tez_t -> eq ta tb
| Timestamp_t, Timestamp_t -> eq ta tb
| Bool_t, Bool_t -> eq ta tb
@ -201,14 +199,13 @@ let parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult Lwt.t = funct
| Prim (_, "uint32", []) -> return @@ Ex (Int_key Uint32)
| Prim (_, "uint64", []) -> return @@ Ex (Int_key Uint64)
| Prim (_, "string", []) -> return @@ Ex String_key
| Prim (_, "float", []) -> return @@ Ex Float_key
| Prim (_, "tez", []) -> return @@ Ex Tez_key
| Prim (_, "bool", []) -> return @@ Ex Bool_key
| Prim (_, "key", []) -> return @@ Ex Key_key
| Prim (_, "timestamp", []) -> return @@ Ex Timestamp_key
| Prim (loc, ("int8" | "int16" | "int32" | "int64"
| "uint8" | "uint16" | "uint32" | "uint64"
| "string" | "float" | "tez" | "bool"
| "string" | "tez" | "bool"
| "key" | "timestamp" as prim), l) ->
fail @@ Invalid_arity (loc, Type, prim, 0, List.length l)
| Prim (loc, ("pair" | "union" | "set" | "map"
@ -217,7 +214,7 @@ let parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult Lwt.t = funct
fail @@ Comparable_type_expected loc
| Prim (loc, prim, _) ->
fail @@ Invalid_primitive (loc, Type, prim)
| Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) ->
| Int (loc, _) | String (loc, _) | Seq (loc, _) ->
fail @@ Invalid_expression_kind loc
type ex_ty = Ex : 'a ty -> ex_ty
@ -233,7 +230,6 @@ let rec parse_ty : Script.expr -> ex_ty tzresult Lwt.t = function
| Prim (_, "uint32", []) -> return @@ Ex (Int_t Uint32)
| Prim (_, "uint64", []) -> return @@ Ex (Int_t Uint64)
| Prim (_, "string", []) -> return @@ Ex String_t
| Prim (_, "float", []) -> return @@ Ex Float_t
| Prim (_, "tez", []) -> return @@ Ex Tez_t
| Prim (_, "bool", []) -> return @@ Ex Bool_t
| Prim (_, "key", []) -> return @@ Ex Key_t
@ -276,19 +272,18 @@ let rec parse_ty : Script.expr -> ex_ty tzresult Lwt.t = function
| "void" | "signature" | "contract"
| "int8" | "int16" | "int32" | "int64"
| "uint8" | "uint16" | "uint32" | "uint64"
| "string" | "float" | "tez" | "bool"
| "string" | "tez" | "bool"
| "key" | "timestamp" as prim), l) ->
fail @@ Invalid_arity (loc, Type, prim, 0, List.length l)
| Prim (loc, prim, _) ->
fail @@ Invalid_primitive (loc, Type, prim)
| Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) ->
| Int (loc, _) | String (loc, _) | Seq (loc, _) ->
fail @@ Invalid_expression_kind loc
let ty_of_comparable_ty
: type a. a comparable_ty -> a ty = function
| Int_key k -> Int_t k
| String_key -> String_t
| Float_key -> Float_t
| Tez_key -> Tez_t
| Bool_key -> Bool_t
| Key_key -> Key_t
@ -298,7 +293,6 @@ let comparable_ty_of_ty
: type a. a ty -> a comparable_ty tzresult = function
| Int_t k -> ok (Int_key k)
| String_t -> ok String_key
| Float_t -> ok Float_key
| Tez_t -> ok Tez_key
| Bool_t -> ok Bool_key
| Key_t -> ok Key_key
@ -335,16 +329,6 @@ let rec parse_tagged_data
return @@ Ex (Bool_t, v)
| Prim (loc, "bool", l) ->
fail @@ Invalid_arity (loc, Constant, "bool", 1, List.length l)
| Float (loc, v) -> begin try
return (Ex (Float_t, float_of_string v))
with _ ->
fail @@ Invalid_constant (loc, "float")
end
| Prim (_, "float", [ arg ]) ->
parse_untagged_data ctxt Float_t arg >>=? fun v ->
return @@ Ex (Float_t, v)
| Prim (loc, "float", l) ->
fail @@ Invalid_arity (loc, Constant, "float", 1, List.length l)
| Prim (_, "timestamp", [ arg ]) ->
parse_untagged_data ctxt Timestamp_t arg >>=? fun v ->
return @@ Ex (Timestamp_t, v)
@ -513,24 +497,16 @@ and parse_untagged_data
match ty, script_data with
(* Void *)
| Void_t, Prim (_, "void", []) -> return ()
| Void_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Float (loc, _) | Seq (loc, _)) ->
| Void_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "void")
(* Strings *)
| String_t, String (_, v) -> return v
| String_t, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) ->
| String_t, (Prim (loc, _, _) | Int (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "string")
(* Floats *)
| Float_t, Float (loc, v) -> begin try
return (float_of_string v)
with _ ->
fail @@ Invalid_constant (loc, "float")
end
| Float_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "float")
(* Booleans *)
| Bool_t, Prim (_, "true", []) -> return true
| Bool_t, Prim (_, "false", []) -> return false
| Bool_t, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Bool_t, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "bool")
(* Integers *)
| Int_t k, Int (loc, v) -> begin try
@ -539,7 +515,7 @@ and parse_untagged_data
| Some i -> return i
with _ -> fail @@ Invalid_constant (loc, string_of_int_kind k)
end
| Int_t k, (Float (loc, _) | Prim (loc, _, _) | String (loc, _) | Seq (loc, _)) ->
| Int_t k, (Prim (loc, _, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, string_of_int_kind k)
(* Tez amounts *)
| Tez_t, String (loc, v) -> begin try
@ -549,10 +525,10 @@ and parse_untagged_data
with _ ->
fail @@ Invalid_constant (loc, "tez")
end
| Tez_t, (Float (loc, _) | Int (loc, _) | Prim (loc, _, _) | Seq (loc, _)) ->
| Tez_t, (Int (loc, _) | Prim (loc, _, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "tez")
(* Timestamps *)
| Timestamp_t, (Float (loc, v) | Int (loc, v)) -> begin
| Timestamp_t, (Int (loc, v)) -> begin
match (Timestamp.of_seconds v) with
| Some v -> return v
| None -> fail @@ Invalid_constant (loc, "timestamp")
@ -570,7 +546,7 @@ and parse_untagged_data
return (Ed25519.Public_key_hash.of_b48check s)
with _ -> fail @@ Invalid_constant (loc, "key")
end
| Key_t, (Prim (loc, _, _) | Seq (loc, _) | Int (loc, _) | Float (loc, _)) ->
| Key_t, (Prim (loc, _, _) | Seq (loc, _) | Int (loc, _)) ->
fail @@ Invalid_constant (loc, "key")
(* Signatures *)
| Signature_t, String (loc, s) -> begin try
@ -582,7 +558,7 @@ and parse_untagged_data
with _ ->
fail @@ Invalid_constant (loc, "signature")
end
| Signature_t, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) ->
| Signature_t, (Prim (loc, _, _) | Int (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "signature")
(* Contracts *)
| Contract_t (ty1, ty2), String (loc, s) ->
@ -591,7 +567,7 @@ and parse_untagged_data
(Lwt.return (Contract.of_b48check s)) >>=? fun c ->
parse_contract ctxt ty1 ty2 loc c >>=? fun _ ->
return (ty1, ty2, c)
| Contract_t _, (Prim (loc, _, _) | Int (loc, _) | Float (loc, _) | Seq (loc, _)) ->
| Contract_t _, (Prim (loc, _, _) | Int (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "contract")
(* Pairs *)
| Pair_t (ta, tb), Prim (_, "pair", [ va; vb ]) ->
@ -600,7 +576,7 @@ and parse_untagged_data
return (va, vb)
| Pair_t _, Prim (loc, "pair", l) ->
fail @@ Invalid_arity (loc, Constant, "pair", 2, List.length l)
| Pair_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Pair_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "pair")
(* Unions *)
| Union_t (tl, _), Prim (_, "left", [ v ]) ->
@ -613,12 +589,12 @@ and parse_untagged_data
return (R v)
| Union_t _, Prim (loc, "right", l) ->
fail @@ Invalid_arity (loc, Constant, "right", 1, List.length l)
| Union_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Union_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "union")
(* Lambdas *)
| Lambda_t (ta, tr), (Seq _ as script_instr) ->
parse_lambda ctxt ta tr script_instr
| Lambda_t (_, _), (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _)) ->
| Lambda_t (_, _), (Prim (loc, _, _) | Int (loc, _) | String (loc, _)) ->
fail @@ Invalid_constant (loc, "lambda")
(* References *)
| Ref_t t, Prim (_, "ref", [ v ]) ->
@ -626,7 +602,7 @@ and parse_untagged_data
return (ref v)
| Ref_t _, Prim (loc, "ref", l) ->
fail @@ Invalid_arity (loc, Constant, "ref", 1, List.length l)
| Ref_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Ref_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "ref")
(* Options *)
| Option_t t, Prim (_, "some", [ v ]) ->
@ -638,7 +614,7 @@ and parse_untagged_data
return None
| Option_t _, Prim (loc, "none", l) ->
fail @@ Invalid_arity (loc, Constant, "none", 0, List.length l)
| Option_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Option_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "option")
(* Lists *)
| List_t t, Prim (_, "list", vs) ->
@ -647,7 +623,7 @@ and parse_untagged_data
parse_untagged_data ctxt t v >>=? fun v ->
return (v :: rest))
[] vs
| List_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| List_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "list")
(* Sets *)
| Set_t t, Prim (_, "set", vs) ->
@ -657,7 +633,7 @@ and parse_untagged_data
return (v :: rest))
[] vs >>=? fun v ->
return (ref v, t)
| Set_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Set_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "set")
(* Maps *)
| Map_t (tk, tv), Prim (_, "map", vs) ->
@ -669,11 +645,11 @@ and parse_untagged_data
return ((k, v) :: rest)
| Prim (loc, "item", l) ->
fail @@ Invalid_arity (loc, Constant, "item", 2, List.length l)
| Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) ->
| Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) ->
fail @@ Invalid_constant (loc, "item"))
[] vs >>=? fun v ->
return (ref v, tk)
| Map_t _, (Prim (loc, _, _) | Float (loc, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
| Map_t _, (Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _)) ->
fail @@ Invalid_constant (loc, "map")
and parse_untagged_comparable_data
@ -899,13 +875,9 @@ and parse_instr
| Prim (_, "nop", []), rest ->
return (Typed (Nop, rest))
(* timestamp operations *)
| Prim (_, "add", []), Item_t (Timestamp_t, Item_t (Float_t, rest)) ->
return (Typed (Add_timestamp_to_period, Item_t (Timestamp_t, rest)))
| Prim (loc, "add", []), Item_t (Timestamp_t, Item_t (Int_t kind, rest)) ->
trace (Bad_stack_item (loc, 2)) (Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Add_timestamp_to_seconds (kind, loc), Item_t (Timestamp_t, rest)))
| Prim (_, "add", []), Item_t (Float_t, Item_t (Timestamp_t, rest)) ->
return (Typed (Add_period_to_timestamp, Item_t (Timestamp_t, rest)))
| Prim (loc, "add", []), Item_t (Int_t kind, Item_t (Timestamp_t, rest)) ->
trace
(Bad_stack_item (loc, 1))
@ -927,33 +899,6 @@ and parse_instr
(Bad_stack_item (loc, 1))
(Lwt.return (unsigned_int_kind kind)) >>=? fun (Eq _) ->
return (Typed (Mul_tez' kind, Item_t (Tez_t, rest)))
(* float operations *)
| Prim (_, "floor", []), Item_t (Float_t, rest) ->
return (Typed (Floor, Item_t (Float_t, rest)))
| Prim (_, "ceil", []), Item_t (Float_t, rest) ->
return (Typed (Ceil, Item_t (Float_t, rest)))
| Prim (_, "inf", []), rest ->
return (Typed (Inf, Item_t (Float_t, rest)))
| Prim (_, "nan", []), rest ->
return (Typed (NaN, Item_t (Float_t, rest)))
| Prim (_, "isnan", []), Item_t (Float_t, rest) ->
return (Typed (IsNaN, Item_t (Bool_t, rest)))
| Prim (loc, "nanan", []), Item_t (Float_t, rest) ->
return (Typed (NaNaN loc, rest))
| Prim (_, "abs", []), Item_t (Float_t, rest) ->
return (Typed (Abs_float, Item_t (Float_t, rest)))
| Prim (_, "neg", []), Item_t (Float_t, rest) ->
return (Typed (Neg_float, Item_t (Float_t, rest)))
| Prim (_, "add", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Add_float, Item_t (Float_t, rest)))
| Prim (_, "sub", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Sub_float, Item_t (Float_t, rest)))
| Prim (_, "mul", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Mul_float, Item_t (Float_t, rest)))
| Prim (_, "div", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Div_float, Item_t (Float_t, rest)))
| Prim (_, "mod", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Mod_float, Item_t (Float_t, rest)))
(* boolean operations *)
| Prim (_, "or", []), Item_t (Bool_t, Item_t (Bool_t, rest)) ->
return (Typed (Or, Item_t (Bool_t, rest)))
@ -1029,8 +974,6 @@ and parse_instr
return (Typed (Compare Bool_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []), Item_t (String_t, Item_t (String_t, rest)) ->
return (Typed (Compare String_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []), Item_t (Float_t, Item_t (Float_t, rest)) ->
return (Typed (Compare Float_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []), Item_t (Tez_t, Item_t (Tez_t, rest)) ->
return (Typed (Compare Tez_key, Item_t (Int_t Int64, rest)))
| Prim (_, "compare", []), Item_t (Key_t, Item_t (Key_t, rest)) ->
@ -1064,10 +1007,6 @@ and parse_instr
parse_ty t >>=? fun (Ex ty) -> begin match ty,stack_ty with
| Int_t kt, Item_t (Int_t kf, rest) ->
return (Typed (Int_of_int (kf, kt), Item_t (Int_t kt, rest)))
| Float_t, Item_t (Int_t kf, rest) ->
return (Typed (Float_of_int kf, Item_t (Float_t, rest)))
| Int_t kt, Item_t (Float_t, rest) ->
return (Typed (Int_of_float kt, Item_t (Int_t kt, rest)))
| ty, Item_t (ty', _) ->
fail (Undefined_cast (loc, Ty ty', Ty ty))
| _, Empty_t ->
@ -1181,7 +1120,7 @@ and parse_instr
(* Generic parsing errors *)
| Prim (loc, prim, _), _ ->
fail @@ Invalid_primitive (loc, Instr, prim)
| (Float (loc, _) | Int (loc, _) | String (loc, _)), _ ->
| (Int (loc, _) | String (loc, _)), _ ->
fail @@ Invalid_expression_kind loc
and parse_contract
@ -1224,7 +1163,6 @@ let unparse_comparable_ty
| Int_key Uint32 -> Prim (-1, "uint32", [])
| Int_key Uint64 -> Prim (-1, "uint64", [])
| String_key -> Prim (-1, "string", [])
| Float_key -> Prim (-1, "float", [])
| Tez_key -> Prim (-1, "tez", [])
| Bool_key -> Prim (-1, "bool", [])
| Key_key -> Prim (-1, "key", [])
@ -1242,7 +1180,6 @@ let rec unparse_ty
| Int_t Uint32 -> Prim (-1, "uint32", [])
| Int_t Uint64 -> Prim (-1, "uint64", [])
| String_t -> Prim (-1, "string", [])
| Float_t -> Prim (-1, "float", [])
| Tez_t -> Prim (-1, "tez", [])
| Bool_t -> Prim (-1, "bool", [])
| Key_t -> Prim (-1, "key", [])
@ -1290,8 +1227,6 @@ let rec unparse_untagged_data
Int (-1, Int64.to_string (to_int64 k v))
| String_t, s ->
String (-1, s)
| Float_t, f ->
Float (-1, string_of_float f)
| Bool_t, true ->
Prim (-1, "true", [])
| Bool_t, false ->
@ -1355,8 +1290,6 @@ let rec unparse_tagged_data
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) ])
| Float_t, f ->
Prim (-1, "float", [ String (-1, string_of_float f) ])
| Bool_t, true ->
Prim (-1, "bool", [ Prim (-1, "true", []) ])
| Bool_t, false ->

13
src/proto/bootstrap/script_repr.ml
View File

@ -29,7 +29,6 @@ let location_encoding =
type expr = (* TODO: turn the location into an alpha ? *)
| Int of location * string
| Float of location * string
| String of location * string
| Prim of location * string * expr list
| Seq of location * expr list
@ -38,8 +37,6 @@ let expr_encoding =
let open Data_encoding in
let int_encoding =
obj1 (req "int" string) in
let float_encoding =
obj1 (req "float" string) in
let string_encoding =
obj1 (req "string" string) in
let prim_encoding expr_encoding =
@ -65,25 +62,21 @@ let expr_encoding =
[ case ~tag:0 int_encoding
(function Int (_, v) -> Some v | _ -> None)
(fun v -> Int (-1, v)) ;
case ~tag:1 float_encoding
(function Float (_, v) -> Some v | _ -> None)
(fun v -> Float (-1, v)) ;
case ~tag:2 string_encoding
case ~tag:1 string_encoding
(function String (_, v) -> Some v | _ -> None)
(fun v -> String (-1, v)) ;
case ~tag:3 (prim_encoding expr_encoding)
case ~tag:2 (prim_encoding expr_encoding)
(function
| Prim (_, v, args) -> Some (v, args)
| _ -> None)
(function (prim, args) -> Prim (-1, prim, args)) ;
case ~tag:4 (seq_encoding expr_encoding)
case ~tag:3 (seq_encoding expr_encoding)
(function Seq (_, v) -> Some v | _ -> None)
(fun args -> Seq (-1, args)) ])
let update_locations ir =
let rec update_locations i = function
| Int (_, v) -> (Int (i, v), succ i)
| Float (_, v) -> (Float (i, v), succ i)
| String (_, v) -> (String (i, v), succ i)
| Prim (_, name, args) ->
let (nargs, ni) =

1
src/proto/bootstrap/script_repr.mli
View File

@ -14,7 +14,6 @@ type location =
type expr =
| Int of location * string
| Float of location * string
| String of location * string
| Prim of location * string * expr list
| Seq of location * expr list

37
src/proto/bootstrap/script_typed_ir.ml
View File

@ -34,7 +34,6 @@ and ('arg, 'ret) typed_contract =
and 'ty comparable_ty =
| Int_key : ('s, 'l) int_kind -> ('s, 'l) int_val comparable_ty
| String_key : string comparable_ty
| Float_key : float comparable_ty
| Tez_key : Tez.t comparable_ty
| Bool_key : bool comparable_ty
| Key_key : public_key_hash comparable_ty
@ -45,7 +44,6 @@ and 'ty ty =
| Int_t : ('s, 'l) int_kind -> ('s, 'l) int_val ty
| Signature_t : signature ty
| String_t : string ty
| Float_t : float ty
| Tez_t : Tez.t ty
| Key_t : public_key_hash ty
| Timestamp_t : Timestamp.t ty
@ -161,12 +159,8 @@ and ('bef, 'aft) instr =
| Concat :
(string * (string * 'rest), string * 'rest) instr
(* timestamp operations *)
| Add_period_to_timestamp :
(float * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr
| Add_seconds_to_timestamp : (unsigned, 'l) int_kind * Script.location ->
((unsigned, 'l) int_val * (Timestamp.t * 'rest), Timestamp.t * 'rest) instr
| Add_timestamp_to_period :
(Timestamp.t * (float * 'rest), Timestamp.t * 'rest) instr
| Add_timestamp_to_seconds : (unsigned, 'l) int_kind * Script.location ->
(Timestamp.t * ((unsigned, 'l) int_val * 'rest), Timestamp.t * 'rest) instr
(* currency operations *)
@ -178,33 +172,6 @@ and ('bef, 'aft) instr =
(Tez.t * ((unsigned, 'l) int_val * 'rest), Tez.t * 'rest) instr
| Mul_tez' : (unsigned, 'l) int_kind ->
((unsigned, 'l) int_val * (Tez.t * 'rest), Tez.t * 'rest) instr
(* float operations *)
| Neg_float :
(float * 'rest, float * 'rest) instr
| Abs_float :
(float * 'rest, float * 'rest) instr
| Add_float :
(float * (float * 'rest), float * 'rest) instr
| Sub_float :
(float * (float * 'rest), float * 'rest) instr
| Mul_float :
(float * (float * 'rest), float * 'rest) instr
| Div_float :
(float * (float * 'rest), float * 'rest) instr
| Mod_float :
(float * (float * 'rest), float * 'rest) instr
| Floor :
(float * 'rest, float * 'rest) instr
| Ceil :
(float * 'rest, float * 'rest) instr
| Inf :
('rest, float * 'rest) instr
| NaN :
('rest, float * 'rest) instr
| IsNaN :
(float * 'rest, bool * 'rest) instr
| NaNaN : Script.location ->
(float * 'rest, 'rest) instr
(* boolean operations *)
| Or :
(bool * (bool * 'rest), bool * 'rest) instr
@ -289,10 +256,6 @@ and ('bef, 'aft) instr =
(('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr
| Checked_int_of_int : ('sf, 'lf) int_kind * ('st, 'lt) int_kind * Script.location ->
(('sf, 'lf) int_val * 'rest, ('st, 'lt) int_val * 'rest) instr
| Int_of_float : ('st, 'lt) int_kind ->
(float * 'rest, ('st, 'lt) int_val * 'rest) instr
| Float_of_int : ('sf, 'lf) int_kind ->
(('sf, 'lf) int_val * 'rest, float * 'rest) instr
(* protocol *)
| Manager :
(('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr

1
src/proto/bootstrap/tezos_context.mli
View File

@ -109,7 +109,6 @@ module Script : sig
type expr =
| Int of location * string
| Float of location * string
| String of location * string
| Prim of location * string * expr list
| Seq of location * expr list