Commit c14d9cd7 authored by Jun Furuse's avatar Jun Furuse

Merge branch 'pre-salting' into 'master'

Pre salting merge

See merge request !4
parents 66e5def5 92365ba2
Pipeline #113161914 passed with stage
in 8 minutes and 36 seconds
# 1.0.2
* Fixed typos of messages
* Fixed OPAM version constraints
# 1.0.1
## Language
......@@ -26,3 +31,7 @@
# 1.0.0
Initial release
# 1.0.1
* Free occurrences of variables of types with `contract`, `operation`, and `big_map` in function abstractions are
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -85,6 +85,13 @@ module P = struct
let rec type_ ty =
let open M.Type in
let attrs = ty.attrs in
let add_attrs ty =
{ ty
with ptyp_attributes =
List.map (fun a -> ({Location.txt=a; loc=Location.none}, PStr [])) attrs }
in
add_attrs @@
match ty.desc with
| TyString -> [%type: string]
| TyNat -> [%type: nat]
......@@ -111,6 +118,8 @@ module P = struct
| TyContract t -> [%type: [%t type_ t] contract]
| TyLambda (t1, t2) -> [%type: [%t type_ t1] -> [%t type_ t2]]
let _type = type_
let rec constant =
let open M.Constant in
function
......@@ -172,12 +181,12 @@ module P = struct
| App (t, ts) -> eapply (iml t) (List.map iml ts)
| Prim (s, _, ts) -> eapply (evar s) (List.map iml ts)
| Let (pv, t1, t2) ->
(*
let ty = type_ pv.typ in
let pv = pvar & Ident.unique_name pv.desc in
*)
let ty = type_ pv.typ in
let pv = pvar & Ident.unique_name pv.desc in
[%expr let [%p pv] : [%t ty] = [%e iml t1] in [%e iml t2]]
(*
[%expr let [%p pv] = [%e iml t1] in [%e iml t2]]
*)
| Switch_or (t, pv1, t1, pv2, t2) ->
let pv1 = pvar & Ident.unique_name pv1.desc in
let pv2 = pvar & Ident.unique_name pv2.desc in
......@@ -350,7 +359,7 @@ let check_unstorable t =
| Fun _ ->
begin try
IdTys.iter (fun (id, ty) ->
if not & Michelson.Type.storable ty then
if not & Michelson.Type.is_packable ty then
raise (E.Found (id, ty)))
& freevars t;
Ok ()
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -33,7 +33,9 @@ module PatVar : sig
end
module Attr : sig
type t = Comment of string
type t =
| Comment of string
type ts = t list
val add : t -> ('a, ts) with_loc_and_type -> ('a, ts) with_loc_and_type
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -36,7 +36,7 @@ let init () =
internal_error ~loc:Location.none "Command 'opam config var prefix' raised an exception: %s" (Printexc.to_string e)
in
Clflags.include_dirs := !Clflags.include_dirs @ [dir];
List.iter (fun s -> prerr_endline @@ "Include: " ^ s) !Clflags.include_dirs
(* List.iter (fun s -> prerr_endline @@ "Include: " ^ s) !Clflags.include_dirs *)
end
let implementation sourcefile outputprefix _modulename (str, _coercion) =
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -55,15 +55,32 @@ let var ~loc env id = match Env.find id env with
| Some (n,_typ) ->
[ COMMENT( "var " ^ Ident.unique_name id, [ DIG n; DUP; DUG (n+1) ]) ]
(* Field annotation cannot appear at the first level of type tree.
The followings are rejectred:
PUSH (nat %nat) 1
RIGHT (string %Vote)
*)
let clean_field_annot typ =
let attrs = List.filter (fun s ->
match s with
| "" -> false
| s when s.[0] = '%' -> false
| _ -> true) typ.attrs
in
{ typ with attrs }
let rec compile env t = match constant t with
| None -> compile' env t
| Some c -> [ PUSH (t.IML.typ, c) ]
| Some c ->
[ PUSH (clean_field_annot t.IML.typ, c) ]
and compile' env t =
let os = desc env t in
let comments =
List.filter_map (function
| IML.Attr.Comment s -> Some s
| IML.Attr.Comment s when !Flags.flags.scaml_debug -> Some s
| _ -> None
) t.IML.attrs
in
match comments with
......@@ -75,13 +92,14 @@ and desc env t =
match t.IML.desc with
| IML.Set _ -> errorf ~loc "Set elements must be constants"
| Map _ -> errorf ~loc "Map bindings must be constants"
| Const c -> [ PUSH (t.typ, c) ]
| Const c ->
[ PUSH (clean_field_annot t.typ, c) ]
| Nil ->
let ty = match t.typ.desc with
| TyList ty -> ty
| _ -> assert false
in
[ NIL ty ]
[ NIL (clean_field_annot ty) ]
| Cons (t1, t2) ->
let os2 = compile env t2 in
let os1 = compile ((Ident.dummy, t2.typ)::env) t1 in
......@@ -91,7 +109,7 @@ and desc env t =
| TyOption ty -> ty
| _ -> assert false
in
[ NONE ty ]
[ NONE (clean_field_annot ty) ]
| IML_Some t1 ->
let os1 = compile env t1 in
os1 @ [ SOME ]
......@@ -101,14 +119,14 @@ and desc env t =
| _ -> assert false
in
let os = compile env t' in
os @ [ LEFT ty ]
os @ [ LEFT (clean_field_annot ty) ]
| Right t' ->
let ty = match t.typ.desc with
| TyOr (ty, _) -> ty
| _ -> assert false
in
let os = compile env t' in
os @ [ RIGHT ty ]
os @ [ RIGHT (clean_field_annot ty) ]
| Unit -> [ UNIT ]
| Var id -> var ~loc env id
......@@ -196,7 +214,7 @@ and desc env t =
let env = [p.desc,p.typ] in
let o = compile env body in
let clean = [ COMMENT ("lambda clean up", [DIP (1, [ DROP 1 ]) ]) ] in
[ LAMBDA (ty1, ty2, o @ clean) ]
[ LAMBDA (clean_field_annot ty1, clean_field_annot ty2, o @ clean) ]
| _ ->
(* fvars: x1:ty1 :: x2:ty2 :: .. :: xn:tyn
......@@ -230,7 +248,7 @@ and desc env t =
in
let len = List.length fvars in
let clean = [ COMMENT ("lambda clean up", [DIP (1, [ DROP (len + 1) ]) ]) ] in
LAMBDA (ity, ty2, extractor @ compile env body @ clean)
LAMBDA (clean_field_annot ity, clean_field_annot ty2, extractor @ compile env body @ clean)
in
let partial_apply =
(* Apply fvars from xn to x1 *)
......@@ -412,3 +430,4 @@ let structure t =
; COMMENT ("entry point", os )
; COMMENT ("final clean up", [ DIP (1, [ DROP (List.length env) ]) ])]
|> clean_failwith
|> dip_1_drop_n_compaction
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -19,7 +19,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -85,7 +85,9 @@ module Type = struct
| TyOperation
| TyContract of t
| TyLambda of t * t
let attribute ss t = { t with attrs= t.attrs @ ss }
let mk desc = { desc ; attrs= [] }
let tyString = mk TyString
......@@ -144,20 +146,98 @@ module Type = struct
and pp fmt t = Mline.pp fmt & to_micheline t
let rec storable ty = match ty.desc with
| TyContract _ | TyOperation | TyBigMap _ -> false
| TyLambda (_t1, _t2) -> true (* XXX I beieve. (i.e. not sure) *)
let rec validate ty =
let open Result.Infix in
let rec f ty = match ty.desc with
| TyBigMap (k, v) ->
f k >>= fun () -> f v >>= fun () ->
if not (is_comparable k) then
Error (ty, "big_map's key type must be comparable")
else if not (is_packable v) then
Error (ty, "big_map's value type must be packable")
else
Ok ()
| TySet e ->
f e >>= fun () ->
if not (is_comparable e) then
Error (ty, "set's element type must be comparable")
else
Ok ()
| TyList t | TyOption t | TySet t -> storable t
| TyMap (k, v) ->
f k >>= fun () -> f v >>= fun () ->
if not (is_comparable k) then
Error (ty, "map's key type must be comparable")
else
Ok ()
| TyContract p ->
f p >>= fun () ->
if not (is_parameterable p) then
Error (ty, "contract's parameter type cannot contain operation")
else
Ok ()
| (TyList ty | TyOption ty) -> f ty
| (TyPair (ty1, ty2) | TyOr (ty1, ty2) | TyLambda (ty1, ty2)) ->
f ty1 >>= fun () -> f ty2
| TyPair (t1, t2) | TyOr (t1, t2)
| TyMap (t1, t2) -> storable t1 && storable t2
| TyString | TyNat | TyInt | TyBytes | TyBool | TyUnit
| TyMutez | TyKeyHash | TyTimestamp | TyAddress | TyChainID
| TyKey | TySignature -> true
| TyString | TyNat | TyInt | TyBytes | TyBool | TyUnit | TyMutez
| TyKeyHash | TyTimestamp | TyAddress |TyChainID | TyKey | TySignature
| TyOperation -> Ok ()
in
f ty
and is_comparable ty =
let rec f ty = match ty.desc with
| TyBigMap _ | TyChainID | TyContract _ | TyKey
| TyLambda _ | TyList _ | TyMap _ | TyOperation
| TyOption _ | TyOr _ | TySet _ | TySignature | TyUnit -> false
| TyString | TyNat | TyInt | TyBytes | TyBool | TyMutez
| TyKeyHash | TyTimestamp | TyAddress -> true
| TyPair (ty1, ty2) -> f ty1 && f ty2 (* since 005_Babylon *)
in
f ty
and is_packable ty =
(* ~allow_big_map:false
~allow_operation:false
~allow_contract:legacy
*)
let rec f ty = match ty.desc with
| TyBigMap _ -> false
| TyOperation -> false
| TyContract _ -> false
| TyLambda (_t1, _t2) -> true
| TyList t | TyOption t | TySet t -> f t
| TyPair (t1, t2) | TyOr (t1, t2) | TyMap (t1, t2) -> f t1 && f t2
| TyString | TyNat | TyInt | TyBytes | TyBool | TyUnit
| TyMutez | TyKeyHash | TyTimestamp | TyAddress | TyChainID
| TyKey | TySignature -> true
in
f ty
and is_parameterable ty =
(* ~allow_big_map:true
~allow_operation:false
~allow_contract:true
*)
let rec f ty = match ty.desc with
| TyBigMap _ -> true
| TyOperation -> false
| TyContract _ -> true
| TyList t | TyOption t | TySet t -> f t
| TyLambda (_t1, _t2) -> true
| TyPair (t1, t2) | TyOr (t1, t2) | TyMap (t1, t2) -> f t1 && f t2
| TyString | TyNat | TyInt | TyBytes | TyBool | TyUnit
| TyMutez | TyKeyHash | TyTimestamp | TyAddress | TyChainID
| TyKey | TySignature -> true
in
f ty
end
module rec Constant : sig
......@@ -310,6 +390,7 @@ and Opcode : sig
val pp : Format.formatter -> t -> unit
val to_micheline : t -> Mline.t
val clean_failwith : t list -> t list
val dip_1_drop_n_compaction : t list -> t list
end = struct
type module_ =
......@@ -444,8 +525,8 @@ end = struct
| EXEC -> !"EXEC"
| FAILWITH -> !"FAILWITH"
| COMMENT (s, ts) ->
add_comment (Some s) & seq (List.map f ts)
| COMMENT (s, [t]) -> add_comment (Some s) & f t
| COMMENT (s, ts) -> add_comment (Some s) & seq (List.map f ts)
| IF_LEFT (t1, t2) ->
prim "IF_LEFT" [ seq & List.map f t1;
seq & List.map f t2 ]
......@@ -579,6 +660,48 @@ end = struct
| Left t -> Left (constant t)
| Right t -> Right (constant t)
| (Unit | Bool _ | Int _ | String _ | Bytes _ | Timestamp _ | Option None as c) -> c
let dip_1_drop_n_compaction ts =
let rec loop n comments = function
| DIP (1, [DROP m]) :: ts -> loop (n + m) comments ts
| COMMENT (c, [DIP (1, [DROP m])]) :: ts -> loop (n + m) (c :: comments) ts
| ts when n > 0 ->
if comments <> [] then
COMMENT (String.concat ", " (List.rev comments),
[ DIP (1, [DROP n]) ]) :: loop 0 [] ts
else
DIP (1, [DROP n]) :: loop 0 [] ts
| [] -> []
| t :: ts ->
let t' = match t with
| DIP (n, ts) -> DIP (n, loop 0 [] ts)
| LAMBDA (t1, t2, ts) -> LAMBDA (t1, t2, loop 0 [] ts)
| IF (ts1, ts2) -> IF (loop 0 [] ts1, loop 0 [] ts2)
| IF_NONE (ts1, ts2) -> IF_NONE (loop 0 [] ts1, loop 0 [] ts2)
| IF_LEFT (ts1, ts2) -> IF_LEFT (loop 0 [] ts1, loop 0 [] ts2)
| IF_CONS (ts1, ts2) -> IF_CONS (loop 0 [] ts1, loop 0 [] ts2)
| COMMENT (c, ts) -> COMMENT (c, loop 0 [] ts)
| ITER ts -> ITER (loop 0 [] ts)
| MAP ts -> ITER (loop 0 [] ts)
| LOOP ts -> LOOP (loop 0 [] ts)
| LOOP_LEFT ts -> LOOP_LEFT (loop 0 [] ts)
| DUP | DIG _ | DUG _ | DROP _ | SWAP | PAIR | ASSERT | CAR | CDR
| LEFT _ | RIGHT _ | APPLY | PUSH _ | NIL _ | CONS | NONE _
| SOME | COMPARE | EQ | LT | LE | GT | GE | NEQ
| ADD | SUB | MUL | EDIV | ABS | ISNAT | NEG | LSL | LSR
| AND | OR | XOR | NOT | EXEC | FAILWITH | UNIT
| EMPTY_SET _ | EMPTY_MAP _ | EMPTY_BIG_MAP _
| SIZE | MEM | UPDATE | CONCAT | SELF | GET
| RENAME _ | PACK | UNPACK _ | SLICE | CAST
| CONTRACT _ | TRANSFER_TOKENS | SET_DELEGATE | CREATE_ACCOUNT
| CREATE_CONTRACT _ | IMPLICIT_ACCOUNT | NOW | AMOUNT | BALANCE
| CHECK_SIGNATURE | BLAKE2B | SHA256 | SHA512 | HASH_KEY | STEPS_TO_QUOTA
| SOURCE | SENDER | ADDRESS | CHAIN_ID -> t
in
t' :: loop 0 [] ts
in
loop 0 [] ts
end
module Module = struct
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -77,7 +77,12 @@ module Type : sig
val pp : Format.formatter -> t -> unit
val to_micheline : t -> Mline.t
val storable : t -> bool
val validate : t -> (unit, (t * string)) Result.t
val is_comparable : t -> bool
val is_packable : t -> bool
val is_parameterable : t -> bool
val attribute : string list -> t -> t
end
module rec Constant : sig
......@@ -183,6 +188,7 @@ and Opcode : sig
val pp : Format.formatter -> t -> unit
val to_micheline : t -> Mline.t
val clean_failwith : t list -> t list
val dip_1_drop_n_compaction : t list -> t list
end
module Module : sig
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -117,7 +117,7 @@ let optimize t =
(* let x = e1 in e2 => e2[e1/x] *)
add_attrs & f t2
| Some 1 when IdTys.for_all (fun (_, ty) -> Michelson.Type.storable ty) (freevars t1) ->
| Some 1 when IdTys.for_all (fun (_, ty) -> Michelson.Type.is_packable ty) (freevars t1) ->
(* let x = e1 in e2 => e2[e1/x] *)
(* contract_self_id must not be inlined into LAMBDAs *)
(* XXX This is adhoc *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......
......@@ -4,7 +4,7 @@
(* *)
(* Jun Furuse, DaiLambda, Inc. *)
(* *)
(* Copyright 2019 DaiLambda, Inc. *)
(* Copyright 2019,2020 DaiLambda, Inc. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
......@@ -18,20 +18,40 @@
module M = Michelson
open M.Opcode
open M.Type
open Tools
open Spotlib.Spot
let simple os = fun _ty pre -> pre @ os
let simple ~loc:_ os = fun _ty pre -> pre @ os
let rec args ty = function
| 0 -> []
| n ->
match ty.desc with
| TyLambda (ty1, ty2) -> ty1 :: args ty2 (n-1)
| _ -> assert false
let comparison ~loc os ty pre =
match args ty 2 with
| [ty1; _ty2] -> (* ty1 == ty2 *)
if not & M.Type.is_comparable ty1 then
errorf ~loc "Comparison operator takes a non comparable type %a"
M.Type.pp ty1;
pre @ os
| _ -> assert false
let primitives =
[ "fst" , (1, simple [CAR])
; "snd" , (1, simple [CDR])
(* XXXX comparable type check *)
; "compare" , (2, simple [COMPARE])
; "=" , (2, simple [COMPARE; EQ])
; "<>" , (2, simple [COMPARE; NEQ])
; "<" , (2, simple [COMPARE; LT])
; ">" , (2, simple [COMPARE; GT])
; "<=" , (2, simple [COMPARE; LE])
; ">=" , (2, simple [COMPARE; GE])
; "compare" , (2, comparison [COMPARE])
; "=" , (2, comparison [COMPARE; EQ])
; "<>" , (2, comparison [COMPARE; NEQ])
; "<" , (2, comparison [COMPARE; LT])
; ">" , (2, comparison [COMPARE; GT])
; "<=" , (2, comparison [COMPARE; LE])
; ">=" , (2, comparison [COMPARE; GE])
; "+" , (2, simple [ADD])
; "+^" , (2, simple [ADD])
; "+$" , (2, simple [ADD])
......@@ -60,7 +80,7 @@ let primitives =
; "lnot" , (1, simple [NOT])
; "List.length" , (1, simple [SIZE])
; "List.map" , (2, fun _typ xs ->
; "List.map" , (2, fun ~loc:_ _typ xs ->
(* lambda : map : S SWAP ;
{ hd; <tl> } : lambda : S MAP {
hd : lambda : S DIP DUP
......@@ -82,7 +102,7 @@ let primitives =
])
; "List.fold_left" , (3, fun _typ xs ->
; "List.fold_left" , (3, fun ~loc:_ _typ xs ->
(*
lam : acc : list : s SWAP; DIP { SWAP } SWAP
list : acc : lam : s ITER {
......@@ -104,7 +124,7 @@ let primitives =
DIP (1, [ DROP 1])
])
; "List.fold_left'" , (3, fun _typ xs ->
; "List.fold_left'" , (3, fun ~loc:_ _typ xs ->
(*
lam : acc : list : s SWAP; DIP { SWAP } SWAP
list : acc : lam : s ITER {
......@@ -123,14 +143,14 @@ let primitives =
DIP (1, [ DROP 1])
])
; "List.rev", (1, fun ty xs ->
; "List.rev", (1, fun ~loc:_ ty xs ->
match ty.desc with
| TyLambda ({ desc= TyList ty }, { desc= TyList _ty' }) ->
(* ty = _ty' *)
xs @ [DIP (1, [NIL ty]); ITER [CONS]]
| _ -> assert false)
; "Set.empty", (0, fun typ xs ->
; "Set.empty", (0, fun ~loc:_ typ xs ->
assert (xs = []);
match typ.desc with
| TySet ty -> [EMPTY_SET ty]
......@@ -140,7 +160,7 @@ let primitives =
; "Set.mem" , (2, simple [MEM])
; "Set.update" , (3, simple [UPDATE])
; "Set.fold" , (3, fun _typ xs ->
; "Set.fold" , (3, fun ~loc:_ _typ xs ->
(*
lam : set : acc : s SWAP DIP { SWAP }
set : acc : lam : s ITER {
......@@ -166,7 +186,7 @@ let primitives =
DIP (1, [ DROP 1 ])
])
; "Set.fold'" , (3, fun _typ xs ->
; "Set.fold'" , (3, fun ~loc:_ _typ xs ->
(*
lam : set : acc : s SWAP DIP { SWAP }
set : acc : lam : s ITER {
......@@ -186,7 +206,7 @@ let primitives =
DIP (1, [ DROP 1 ])
])
; "Loop.left" , (2, fun typ xs ->
; "Loop.left" , (2, fun ~loc:_ typ xs ->
let rty =
match typ.desc with
| TyLambda (_, { desc= TyLambda(_, rty) }) -> rty
......@@ -216,7 +236,7 @@ let primitives =
; "Bytes.concat", (2, simple [CONCAT])
; "Bytes.length", (1, simple [SIZE])
; "Map.empty", (0, fun typ xs ->
; "Map.empty", (0, fun ~loc:_ typ xs ->
assert (xs = []);
match typ.desc with
| TyMap (ty1,ty2) -> [EMPTY_MAP (ty1, ty2)]
......@@ -227,7 +247,7 @@ let primitives =
; "Map.mem", (2, simple [MEM])
; "Map.update", (3, simple [UPDATE])
; "Map.map", (2, fun _typ xs ->
; "Map.map", (2, fun ~loc:_ _typ xs ->
(* lambda : map : S SWAP ;
{ (k,v); <tl> } : lambda : S MAP {
(k, v) : lambda : S DIP DUP
......@@ -256,7 +276,7 @@ let primitives =
DIP (1, [ DROP 1 ])
])
; "Map.map'", (2, fun _typ xs ->
; "Map.map'", (2, fun ~loc:_ _typ xs ->
(* lambda : map : S SWAP ;
{ (k,v); <tl> } : lambda : S MAP {
(k, v) : lambda : S DIP DUP
......@@ -276,7 +296,7 @@ let primitives =
DIP (1, [ DROP 1 ])
])
; "Map.fold" , (3, fun _typ xs ->
; "Map.fold" , (3, fun ~loc:_ _typ xs ->
(*
lam : map : acc : s SWAP DIP { SWAP }
set : acc : lam : s ITER {
......@@ -307,7 +327,7 @@ let primitives =
])
; "Map.fold'" , (3, fun _typ xs ->
; "Map.fold'" , (3, fun ~loc:_ _typ xs ->
(*