...
 
Commits (31)
# 1.0.3
* Field and constructor annotations in output Michelson code
* Very rough implementation of --scaml-revert, which is to revert SCaml expression from a Michelson value and its SCaml type.
* Checks for comparable, packable, and parameterable types.
* Fixed the compilation of SELF by introducing Annot "not_expand" not to expand let-def.
* Michelson optimziation : DIP { DROP } x n => DIP { DROP n }
* Introduce docker file
# 1.0.2
* Fixed typos of messages
......
FROM ubuntu:18.04
MAINTAINER Jun FURUSE <jun.furuse@dailambda.jp>
# # Replacing the source
# RUN sed -e 's|/archive\.ubuntu\.com/ubuntu|/ftp.jaist.ac.jp/pub/Linux/ubuntu|g' /etc/apt/sources.list > /tmp/sources.list
# RUN mv /tmp/sources.list /etc/apt/sources.list
RUN apt-get clean
RUN apt-get update
# Git
RUN apt install -y --no-install-recommends git ca-certificates
# OPAM (using old OCaml)
WORKDIR /
RUN git clone https://github.com/ocaml/opam
WORKDIR opam
RUN git checkout 2.0.3
RUN apt install -y --no-install-recommends \
curl pkg-config m4 unzip ocaml-nox git make patch
RUN apt install -y --no-install-recommends rsync
RUN apt install -y --no-install-recommends g++ # Required for the OPAM's internal solver
RUN ./configure
RUN make lib-ext && make && make install
RUN opam init -a --bare --disable-sandboxing # bwrap does not work...
RUN rm -rf /opam
RUN apt remove -y ocaml-nox # We do not need the old OCaml
RUN apt remove -y g++ # Required for the external solver
RUN apt autoremove -y
# SCaml
WORKDIR /
RUN git clone https://gitlab.com/dailambda/scaml.git
WORKDIR /scaml
RUN opam switch create . ocaml-base-compiler.4.07.1
RUN opam update
RUN git pull
RUN git checkout @COMMIT@
RUN apt install -y --no-install-recommends libgmp-dev
RUN eval $(opam env) && env && opam install -y vendors/*/*.opam src/scaml.opam
# Cleanup
WORKDIR /
RUN du -sh /usr /scaml /root /var
# Under /scaml, destorying the local OPAM switch
RUN opam clean -a
RUN rm -rf /scaml/_opam/.opam-switch
RUN tar zcf /tmp/scaml.tgz /scaml/_opam/lib/stublibs /scaml/_opam/lib/ocaml/stdlib.cmi /scaml/_opam/bin/scamlc /scaml/_opam/lib/scaml
RUN rm -rf /scaml/_opam
RUN tar xvf /tmp/scaml.tgz
# Destroy OPAM
RUN rm -rf /root/.opam
# Clean and destroy APT
RUN rm -rf /usr/local
RUN apt remove -y git gcc cpp-7 perl make
RUN apt remove -y '*-dev' > /dev/null 2>&1
RUN apt-get clean
RUN apt autoremove -y
RUN rm -rf /var/lib/apt
RUN du -sh /usr /scaml /root /var
RUN SCAMLIB=/scaml/_opam/lib/scaml /scaml/_opam/bin/scamlc /scaml/src/tests/app_vote.ml && echo OK
ENV SCAMLIB /scaml/_opam/lib/scaml
ENV PATH /scaml/_opam/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin
CMD [ "scamlc", "--scaml-version" ]
#!/bin/bash
set -e
COMMIT=$1
if [ -z $COMMIT ]; then
echo Using master
COMMIT=master
fi
sed -e "s/@COMMIT@/$COMMIT/g" Dockerfile.in > Dockerfile
docker build --squash=true -t dailambda/scaml:$COMMIT .
......@@ -12,9 +12,9 @@ If you are not familiar with OCaml, please learn it first.
The compiler `scamlc` has almost the same interface as `ocamlc`.
`scamlc xxx.ml` compiles `xxx.ml` to `xxx.tz`.
### Converrsion mode: `scamlc --scaml-convert`
### Conversion mode: `scamlc --scaml-convert`
There is a SCaml specific compiler switch `--scaml-convert`.
SCaml specific compiler switch `--scaml-convert`.
With this option, `scamlc` command takes a `.ml` and print Michelson representations of
ML constants and types to stdout. The conversion targets must be defined as toplevel
declarations. For example:
......@@ -50,3 +50,47 @@ v: Right (Right { Pair "jon" (Pair 18 10000000000) ; Pair "dow" (Pair 50 1000000
Note that the values must be constants. Constructors and types can refer to types
defined in other modules, as far as they are already compiled to `.cmi` files.
### Revert mode: `scamlc --scaml-revert file`
SCaml specific compiler switch `--scaml-revert file`, where `file` is a file name
which contains Michelson constant expression.
With this option, `scamlc` command takes a `.ml` of one type definition, then translate
the Michelson constant expression in `file` as an SCaml value of the type in `.ml`,
then print out the SCaml expression to stdout. For example, suppose we have `hoo.ml`
of the example of `--scaml-convert`. Create `hoo_type.ml` with a type alias definition
of `Hoo.t`:
```ocaml
(* hoo_u.ml *)
type u = Hoo.u (* Refers the type defined in hoo.ml in the example of --scaml-convert *)
```
Prepare a file with the Michelson constant obtained in the example of the conversion:
```
/* value.tz */
Right (Right { Pair "jon" (Pair 18 10000000000) ; Pair "dow" (Pair 50 1000000) })
```
```shell
$ scamlc --scaml-revert value.tz hoo_u.ml
Boo
[{ name = "jon"; age = (Nat 18); salary = (Tz 10000.000000) };
{ name = "dow"; age = (Nat 50); salary = (Tz 1.000000) }]
```
Note that the values must be constants. Constructors and types can refer to types
defined in other modules, as far as they are already compiled to `.cmi` files.
## Where to find "SCamlib" module
To compile smart contracts, you need to use `SCaml` module which declares the primitives for them. The module `SCaml` is seeked in directories in the following order:
* In the current directory.
* Directories specified by `-I <dir>` option.
* If `--scaml-noscamlib` is not specified:
* Directory specified by the environment variable `SCAMLIB`.
* If `SCAMLIB` is not speicified, directory `` `opam config var prefix`/lib/scaml``.
......@@ -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 *)
......@@ -37,6 +37,7 @@ end
module Attr = struct
type t =
| Comment of string
| Annot of string
type ts = t list
......@@ -85,6 +86,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 +119,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 +182,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 +360,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 ~legacy:false 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,10 @@ module PatVar : sig
end
module Attr : sig
type t = Comment of string
type t =
| Comment of string
| Annot 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 *)
......@@ -18,26 +18,40 @@ open Tools
module M = Michelson
let init () =
if not !Flags.flags.scaml_noscamlib then begin
(* exec opam config var prefix *)
let dir = match
let open Command in
exec ["opam"; "config"; "var"; "prefix"]
|> stdout
|> wait
|> must_exit_with 0
with
| dir::_ -> String.chop_eols dir ^/ "lib/scaml"
| [] ->
internal_error ~loc:Location.none "Command 'opam config var prefix' answered nothing"
| exception (Failure s) ->
internal_error ~loc:Location.none "Command 'opam config var prefix' has failed: %s" s
| exception e ->
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
end
(* If --scaml-noscamlib is specified, None.
If SCAMLLIB is specified, SCAMLLIB is chosen.
Otherwise, `opam config var prefix`/lib/scaml is used.
If `opam config var prefix` does not print a directory nor crashes,
scamlc prints out a warning and continues with None
*)
let scamllib =
if !Flags.flags.scaml_noscamlib then None
else
match Sys.getenv "SCAMLIB" with
| dir -> Some dir
| exception Not_found ->
(* exec opam config var prefix *)
match
let open Command in
exec ["opam"; "config"; "var"; "prefix"]
|> stdout
|> wait
|> must_exit_with 0
with
| dir::_ -> Some (String.chop_eols dir ^/ "lib/scaml")
| [] ->
Format.eprintf "Warning: Command 'opam config var prefix' answered nothing@."; None
| exception (Failure s) ->
Format.eprintf "Warning: Command 'opam config var prefix' has failed: %s" s; None
| exception e ->
Format.eprintf "Warning: Command 'opam config var prefix' raised an exception: %s" (Printexc.to_string e); None
in
match scamllib with
| None -> ()
| Some dir -> Clflags.include_dirs := !Clflags.include_dirs @ [dir]
let implementation sourcefile outputprefix _modulename (str, _coercion) =
let parameter, storage, t = Translate.implementation sourcefile str in
......@@ -83,9 +97,19 @@ let convert _sourcefile _outputprefix _modulename (str, _coercion) =
Format.printf "%s: @[<2>%a@]@." (Ident.name id) M.Constant.pp c
end) ts
let revert m _sourcefile _outputprefix _modulename (str, _coercion) =
match File.to_string m with
| Error (`Exn e) -> raise e
| Ok m ->
match Revert.do_revert str m with
| Error e -> failwith e
| Ok parsetree ->
Format.eprintf "%a@." Pprintast.expression parsetree
let compile sourcefile outputprefix modulename (typedtree, coercion) =
let f =
if !Flags.flags.scaml_convert then convert
else implementation
let f = match !Flags.flags.scaml_mode with
| None | Some Compile -> implementation
| Some Convert -> convert
| Some (Revert s) -> revert s
in
f sourcefile outputprefix modulename (typedtree, 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 *)
......@@ -407,8 +425,9 @@ let structure t =
let p2, t = get_abst t in
let env = ((p2.desc,p2.typ)::(p1.desc,p1.typ)::env) in
let os = compile env t in
[ COMMENT ("defs", if ops = [] then [] else [DIP (1, ops)])
[ COMMENT ("top defs", if ops = [] then [] else [DIP (1, ops)])
; COMMENT ("entry point init", [DUP ; CDR; DIP (1, [CAR])])
; COMMENT ("entry point", os )
; COMMENT ("entry point code", 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 *)
......@@ -16,18 +16,28 @@ open Spotlib.Spot
open Ocaml_conv.Default
type t =
type mode =
| Compile
| Convert
| Revert of string
and t =
{ iml_optimization : bool
; iml_pattern_match : bool
; scaml_debug : bool
; scaml_convert : bool
; scaml_mode : mode option
; scaml_noscamlib : bool
; dump_iml0 : bool
; dump_iml : bool
} [@@deriving conv{ocaml}]
let pp = Camlon.Ocaml.format_with ocaml_of_t
let set_mode t m =
match t.scaml_mode with
| None -> { t with scaml_mode = Some m }
| Some _ -> failwith "You cannot change SCaml running mode twice"
let eval flags (k, v) =
let must_be_a_bool () = Error "attribute type error: must be a bool" in
match String.concat "." & Longident.flatten k, v with
......@@ -37,8 +47,12 @@ let eval flags (k, v) =
| "iml_pattern_match", _ -> must_be_a_bool ()
| "scaml_debug", `Bool b -> Ok { flags with scaml_debug= b }
| "scaml_debug", _ -> must_be_a_bool ()
| "scaml_convert", `Bool b -> Ok { flags with scaml_convert= b }
| "scaml_convert", _ -> must_be_a_bool ()
(*
| "scaml_convert", `Unit -> set_mode flags Convert
| "scaml_convert", _ -> must_be_a_unit ()
| "scaml_revert", `String s -> set_mode flags (Revert s)
| "scaml_revert", _ -> must_be_a_unit ()
*)
| "scaml_noscamlib", `Bool b -> Ok { flags with scaml_noscamlib= b }
| "scaml_noscamlib", _ -> must_be_a_bool ()
| "dump_iml0", `Bool b -> Ok { flags with dump_iml0= b }
......@@ -51,7 +65,7 @@ let flags = ref
{ iml_optimization = true
; iml_pattern_match = true
; scaml_debug = begin try ignore (Sys.getenv "SCAML_DEBUG"); true with _ -> false end
; scaml_convert = false
; scaml_mode = None
; scaml_noscamlib = false
; dump_iml0 = false
; dump_iml = false
......
......@@ -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 *)
......@@ -14,15 +14,20 @@
open Spotlib.Spot
type t =
{ iml_optimization : bool
type mode =
| Compile
| Convert
| Revert of string
and t =
{ iml_optimization : bool
; iml_pattern_match : bool
; scaml_debug : bool
; scaml_convert : bool (** type and value conversion mode *)
; scaml_noscamlib : bool (** do not add -I `opam config var prefix`/scaml *)
; dump_iml0 : bool
; dump_iml : bool
}
; scaml_debug : bool
; scaml_mode : mode option
; scaml_noscamlib : bool (** do not add -I `opam config var prefix`/scaml *)
; dump_iml0 : bool
; dump_iml : bool
} [@@deriving conv{ocaml}]
val flags : t ref
......@@ -30,3 +35,4 @@ val pp : Format.t -> t -> unit
val eval : t -> Longident.t * [`Bool of bool | `Constant of Parsetree.constant ] -> (t, string) Result.t
val update : (t -> t) -> unit
val if_debug : (unit -> unit) -> unit
val set_mode : t -> mode -> t
......@@ -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 *)
......@@ -206,8 +206,10 @@ let main () =
(* SCaml *)
; "--scaml-debug", Arg.Unit (fun () -> Flags.(flags := { !flags with scaml_debug = true })),
"Print SCaml debug messages"
; "--scaml-convert", Arg.Unit (fun () -> Flags.(flags := { !flags with scaml_convert = true })),
; "--scaml-convert", Arg.Unit (fun () -> Flags.(flags := set_mode !flags Convert)),
"Convert types and values, instead of compling a smart contract"
; "--scaml-revert", Arg.String (fun s -> Flags.(flags := set_mode !flags (Revert s))),
"Revert values, instead of compling a smart contract"
; "--scaml-noscamlib", Arg.Unit (fun () -> Flags.(flags := { !flags with scaml_noscamlib = true })),
"Do not add default directory for SCamlib to the list of include directories"
; "--scaml-version", Arg.Unit (fun () ->
......
......@@ -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 ~legacy:false 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 =
(* See Script_ir_translator.parse_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 ~legacy ty =
(* leagcy: allow to pack contracts for hash/signature checks
See Script_ir_translator.I_PACK case.
*)
let rec f ty = match ty.desc with
| TyBigMap _ -> false
| TyOperation -> false
| TyContract _ -> legacy
| 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 : legacy: bool -> 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 *)
......@@ -112,12 +112,13 @@ let optimize t =
| Let (p, t1, t2) ->
let t2 = f t2 in
let vmap = count_variables t2 in
let not_expand = not & List.mem (Attr.Annot "not_expand") t.attrs in
begin match VMap.find_opt p.desc vmap with
| None ->
(* 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 ~legacy:false ty) (freevars t1) && not not_expand ->
(* 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 ->
(*
lam : map : acc : s SWAP DIP { SWAP }
set : acc : lam : s ITER {
......@@ -334,7 +354,7 @@ let primitives =
(* big map *)
; "BigMap.empty", (0, fun typ xs ->
; "BigMap.empty", (0, fun ~loc:_ typ xs ->
assert (xs = []);
match typ.desc with
| TyBigMap (ty1,ty2) -> [EMPTY_BIG_MAP (ty1, ty2)]
......@@ -343,18 +363,28 @@ let primitives =
; "BigMap.mem", (2, simple [MEM])
; "BigMap.update", (3, simple [UPDATE])
; "Obj.pack", (1, simple [ PACK ])
; "Obj.pack", (1, fun ~loc ty pre ->
match args ty 1 with
| [ aty ] ->
if not & M.Type.is_packable ~legacy:true aty then
errorf ~loc "Obj.pack cannot take a non packable type %a"
M.Type.pp aty;
pre @ [ PACK ]
| _ -> assert false)
; "Obj.unpack", (1, fun ty xs ->
; "Obj.unpack", (1, fun ~loc ty xs ->
match ty.desc with
| TyLambda (_, { desc= TyOption ty }) ->
if not & M.Type.is_packable ~legacy:false ty then
errorf ~loc "Obj.unpack cannot unpack to a non packable type %a"
M.Type.pp ty;
xs @ [ UNPACK ty ]
| _ -> assert false)
; "String.slice", (3, simple [ SLICE ])
; "Bytes.slice", (3, simple [ SLICE ]) (* XXX not tested *)
; "Contract.contract", (1, fun ty xs ->
; "Contract.contract", (1, fun ~loc:_ ty xs ->
match ty.desc with
| TyLambda (_, { desc= TyOption ({ desc= TyContract ty }) }) ->
xs @ [ CONTRACT ty ]
......
......@@ -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 *)
......@@ -14,4 +14,8 @@
open Michelson
val primitives : (string * (int * (Type.t -> Opcode.t list -> Opcode.t list))) list
val primitives :
(string *
(int
* (loc:Location.t -> Type.t -> Opcode.t list -> Opcode.t list)))
list
This diff is collapsed.
val do_revert : Typedtree.structure -> string -> (Parsetree.expression, string) result
opam-version: "2.0"
name: "scaml"
version: "1.0.2"
version: "1.0.3"
authors: "Jun Furuse"
maintainer: "jun.furuse@dailambda.jp"
synopsis: "SCaml, Smart Contract Abstract Machine Language"
......
(*
STORAGE= Int 2
INPUT= Int 3
*)
open SCaml
let main p s = ([], s + p)
......@@ -180,14 +180,21 @@ let parameter =
; dest= Contract.implicit_account (Key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
}
}
; sigs= [ Some (Signature "edsigu4chLHh7rDAUxHyifHYTJyuS8zybSSFQ5eSXydXD7PWtHXrpeS19ds3hA587p5JNjyJcZbLx8QtemuJBEFkLyzjAhTjjta"); None ]
(* signature is obtained by
tezos-client sign bytes 0x0507070707002a050507070080897a0a00000016000002298c03ed7d454a101eb7022bc95f7e5f41ac7807070a00000016011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe6000a000000047a06a770 for bootstrap1
The binary is obtained by app_multisig_target.ml
*)
; sigs= [ Some (Signature "edsigtteMcYkviZ3rTaM6N7DWvgsyoTmEHGo91Q63qNJNYXFhTwWzmytanUj8G44aEZ8QDJt3myyxjuVwvRMikSJauZ96AvshWJ"); None ]
}
let storage =
{ stored_counter= Nat 42
; threshold= Nat 1
; keys= [ Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
; Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
(* keys are obtained from public_keys of sandboxed node *)
; keys= [ Key "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" (* bootstrap1 *)
; Key "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" (* bootstrap2 *)
]
}
......
(*
INPUT= ()
STORAGE= (None : bytes option)
*)
open SCaml
type storage =
{ stored_counter : nat
; threshold : nat
; keys : key list
}
type parameter =
{ payload : payload
; sigs : signature option list
}
and payload =
{ counter : nat
; action : action
}
and action =
| Transfer of transfer
| Delegate of key_hash option
| Change_keys of change_keys
and transfer =
{ amount : tz
; dest : unit contract
}
and change_keys =
{ threshold : nat
; keys : key list
}
(*
(Some 0x0507070707002a050507070080897a0a00000016000002298c03ed7d454a101eb7022bc95f7e5f41ac7807070a00000016011d23c1d3d2f8a4ea5e8784b8f7ecf2ad304c0fe6000a000000047a06a770)
*)
let main parameter (storage : bytes option) : operations * bytes option =
(* pair the payload with the current contract address, to ensure signatures
can't be replayed accross different contracts if a key is reused. *)
let signature_target =
Obj.pack ( parameter.payload
, Contract.address Contract.self
, Global.get_chain_id ()
)
in
[], Some signature_target
let parameter =
{ payload= { counter= Nat 42
; action= Transfer { amount= Tz 1.0
; dest= Contract.implicit_account (Key_hash "tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx")
}
}
; sigs= [ Some (Signature "edsigu4chLHh7rDAUxHyifHYTJyuS8zybSSFQ5eSXydXD7PWtHXrpeS19ds3hA587p5JNjyJcZbLx8QtemuJBEFkLyzjAhTjjta"); None ]
}
(*
let storage =
{ stored_counter= Nat 42
; threshold= Nat 1
; keys= [ Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
; Key "edpkuSR6ywqsk17myFVRcw2eXhVib2MeLc9D1QkEQb98ctWUBwSJpF"
]
}
*)
let test () _ =
let ops, res = main parameter None in
ops, res
SCaml port of https://www.michelson-lang.com/contract-a-day.html
open SCaml
let main (p:string) (s:string) = [], s
(*
parameter string ;
storage string ;
code { { /* defs */ } ;
{ /* entry point init */ DUP ; CDR ; DIP { CAR } } ;
{ /* entry point */
{ /* entry main_1004 */
{ /* = __s_1163, = s_1006, = __v_1164, = __s_1161 */ { /* var storage_1158 */ DUP } } ;
NIL operation ;
PAIR } } ;
{ /* final clean up */ DIP { DROP 2 } } } ;
* parameter is restored from the pair, but never used.
* We do not use UNPAIR but another variant.
* storage is DUPed but the usage is linear.
*)
open SCaml
let main kh () =
let c = Contract.implicit_account kh in
[ Operation.transfer_tokens () (Tz 1.0) c ], ()
(*
parameter key_hash;
return unit;
storage unit;
code { CAR; DEFAULT_ACCOUNT; # Create an account for the recipient of the funds
DIP{UNIT}; # Push a value of the storage type below the contract
PUSH tez "1.00"; # The person can have a ꜩ
UNIT; # Push the contract's argument type
TRANSFER_TOKENS; # Run the transfer
PAIR }; # Cleanup and put the return values
*)
(*
parameter key_hash ;
storage unit ;
code { { /* defs */ } ;
{ /* entry point init */ DUP ; CDR ; DIP { CAR } } ;
{ /* entry point */
{ /* entry main_1004 */
PUSH unit Unit ;
NIL operation ;
{ /* = __c_1165, = c_1006, = __v_1166, = __x_1163 */
{ /* = __kh_1171, = kh_1005, = __v_1172, = __kh_1161 */
{ /* var global_param_1160 */ DIG 3 ; DUP ; DUG 4 } } ;
IMPLICIT_ACCOUNT } ;
PUSH mutez 1000000 ;
PUSH unit Unit ;
TRANSFER_TOKENS ;
CONS ;
PAIR } } ;
{ /* final clean up */ DIP { DROP 2 } } } ;
* Apart from the initial parameter handling, the code is very optimal.
*)
open SCaml
let main () threshold =
if Global.get_amount () < threshold then failwith "send more";
[], threshold
(*
parameter unit;
return unit;
storage tez; # How much you have to send me
code {CDR; DUP; # Get the amount required (once for comparison, once to save back in storage)
AMOUNT; CMPLT; # Check to make sure no one is wasting my time
IF {FAIL} {UNIT; PAIR}} # Finish the transaction or reject the person
*)
(*
parameter unit ;
storage mutez ;
code { { /* defs */ } ;
{ /* entry point init */ DUP ; CDR ; DIP { CAR } } ;
{ /* entry point */
{ /* entry main_1004 */
{ /* = __threshold_1163, = threshold_1005, = __v_1164, = __threshold_1161 */
{ /* var storage_1158 */ DUP } } ;
PUSH unit Unit ;
DROP ;
AMOUNT ;
COMPARE ;
LT ;
IF { PUSH string "send more" ; FAILWITH } { UNIT } ;
DROP ;
{ /* = __threshold_1163, = threshold_1005, = __v_1164, = __threshold_1161 */
{ /* var storage_1158 */ DUP } } ;
NIL operation ;
PAIR } } ;
{ /* final clean up */ DIP { DROP 2 } } } ;
* get_amount () produced PUSH UNIT ; DROP ; AMOUNT The argument is required for the simulation
in OCaml side, but it produces meaningless PUSH-then-DROP. We can clean it in Michelson level.
* if e1 then e2 ; e3 e2 must always end with FAILWITH.
The code is now compiled to IF { ... FAILWITH } { UNIT } ; DROP ; e3 but compiled to
IF { ... FAILWITH } { e3 }
*)
open SCaml
let main (ss : int list) _storage =
[],
Loop.left (fun (ss,rev) ->
match ss with
| [] -> Right rev
| s::ss -> Left (ss, s::rev)) (ss, [])
(*
Here's a contract that takes a list of strings and reverses it. This contract gets into the list instructions and the LOOP instruction.
parameter (list string);
return (list string);
storage unit;
code { CAR; NIL string; SWAP; PUSH bool True; # Set up loop
LOOP { IF_CONS {SWAP; DIP{CONS}; PUSH bool True} # Cons onto accumulator if non-empty
{NIL string; PUSH bool False}}; # Handle empty list
DROP; UNIT; SWAP; PAIR}
Wow, the old Michelson can return a value!
*)
(*
parameter (list int) ;
storage (list int) ;
code { { /* defs */ } ;