Merge branch 'master' of gitlab.com:gabriel.alfour/ligo

src/compiler/compiler_program.ml

@@ -86,10 +86,14 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
   let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
   let error_message () = Format.asprintf  "%a" PP.expression expr in
 
-  let return ?env' code =
-    let env' =
-      let default = env in
-      Environment.add ("_tmp_expression" , ty) @@ Option.unopt ~default env' in
+  let return ?prepend_env ?end_env code =
+    let%bind env' =
+      match (prepend_env , end_env) with
+      | (Some _ , Some _) -> simple_fail ("two args to return at " ^ __LOC__)
+      | None , None -> ok @@ Environment.add ("_tmp_expression" , ty) env
+      | Some prepend_env , None ->
+        ok @@ Environment.add ("_tmp_expression" , ty) prepend_env
+      | None , Some end_env -> ok end_env in
     let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
     let%bind output_type = Compiler_type.type_ ty in
     let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in
@@ -117,9 +121,21 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
 
   trace (error (thunk "compiling expression") error_message) @@
   match expr' with
-  | E_capture_environment c ->
+  | E_environment_capture c ->
       let%bind code = Compiler_environment.pack_select env c in
       return @@ code
+  | E_environment_load (expr , load_env) ->
+      let%bind (expr' , _) = translate_expression expr env in
+      let%bind clear = Compiler_environment.select env [] in
+      let%bind unpack = Compiler_environment.unpack load_env in
+      return ~end_env:load_env @@ seq [
+        expr' ;
+        dip clear ;
+        unpack ;
+      ]
+  | E_environment_select sub_env ->
+      let%bind code = Compiler_environment.select_env env sub_env in
+      return ~end_env:sub_env code
   | E_literal v ->
       let%bind v = translate_value v in
       let%bind t = Compiler_type.type_ ty in
@@ -173,8 +189,15 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
       | _ -> simple_fail "E_applicationing something not appliable"
     )
   | E_variable x ->
-      let%bind code = Compiler_environment.get env x in
-      return code
+    let%bind code = Compiler_environment.get env x in
+    return code
+  | E_sequence (a , b) ->
+    let%bind (a' , env_a) = translate_expression a env in
+    let%bind (b' , env_b) = translate_expression b env_a in
+    return ~prepend_env:env_b @@ seq [
+      a' ;
+      b' ;
+    ]
   | E_constant(str, lst) ->
       let module L = Logger.Stateful() in
       let%bind lst' =
@@ -285,6 +308,48 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m
         ]) in
       return code
     )
+  | E_assignment (name , lrs , expr) -> (
+      let%bind (expr' , env') = translate_expression expr env in
+      let%bind get_code = Compiler_environment.get env' name in
+      let modify_code =
+        let aux acc step = match step with
+          | `Left -> seq [dip i_unpair ; acc ; i_pair]
+          | `Right -> seq [dip i_unpiar ; acc ; i_piar]
+        in
+        let init = dip i_drop in
+        List.fold_right' aux init lrs
+      in
+      let%bind set_code = Compiler_environment.set env name in
+      let error =
+        let title () = "michelson type-checking patch" in
+        let content () =
+          let aux ppf = function
+            | `Left -> Format.fprintf ppf "left"
+            | `Right -> Format.fprintf ppf "right" in
+          Format.asprintf "Sub path: %a\n"
+            PP_helpers.(list_sep aux (const " , ")) lrs
+        in
+        error title content in
+      trace error @@
+      return ~end_env:env @@ seq [
+        expr' ;
+        get_code ;
+        i_swap ; modify_code ;
+        set_code ;
+      ]
+    )
+  | E_while (expr, block) -> (
+      let%bind (expr' , env') = translate_expression expr env in
+      let%bind (block' , env'') = translate_expression block env' in
+      let%bind restrict_block = Compiler_environment.select_env env'' env' in
+      return @@ seq [
+        expr' ;
+        prim ~children:[seq [
+            block' ;
+            restrict_block ;
+            expr']] I_LOOP ;
+      ]
+    )
 
 and translate_statement ((s', w_env) as s:statement) : michelson result =
   let error_message () = Format.asprintf "%a" PP.statement s in

src/mini_c/PP.ml

@@ -61,7 +61,9 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
   fprintf ppf "%a -> %a" value a value b
 
 and expression' ppf (e:expression') = match e with
-  | E_capture_environment s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s
+  | E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s
+  | E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env
+  | E_environment_select env -> fprintf ppf "select %a" environment env
   | E_variable v -> fprintf ppf "%s" v
   | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
   | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
@@ -73,8 +75,13 @@ and expression' ppf (e:expression') = match e with
   | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %s -> %a" expression c expression n name expression s
   | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
       fprintf ppf "%a ?? %s -> %a : %s -> %a" expression c name_l expression l name_r expression r
+  | E_sequence (a , b) -> fprintf ppf "%a ; %a" expression a expression b
   | E_let_in ((name , _) , expr , body) ->
       fprintf ppf "let %s = %a in %a" name expression expr expression body
+  | E_assignment (r , path , e) ->
+      fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e
+  | E_while (e , b) ->
+      fprintf ppf "while (%a) %a" expression e expression b
 
 and expression : _ -> expression -> _ = fun ppf e ->
   expression' ppf e.content

src/mini_c/types.ml

@@ -53,7 +53,9 @@ and selector = var_name list
 
 and expression' =
   | E_literal of value
-  | E_capture_environment of selector
+  | E_environment_capture of selector
+  | E_environment_select of environment
+  | E_environment_load of (expression * environment)
   | E_constant of string * expression list
   | E_application of expression * expression
   | E_variable of var_name
@@ -64,6 +66,9 @@ and expression' =
   | E_if_none of expression * expression * ((var_name * type_value) * expression)
   | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression)
   | E_let_in of ((var_name * type_value) * expression * expression)
+  | E_sequence of (expression * expression)
+  | E_assignment of (string * [`Left | `Right] list * expression)
+  | E_while of expression * expression
 
 and expression = {
   content : expression' ;
@@ -97,10 +102,6 @@ and anon_function = {
   result : expression ;
 }
 
-and capture =
-  | No_capture (* For functions that don't capture their environments. Quotes. *)
-  | Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
-
 and block' = statement list
 
 and block = block' * environment_wrap

src/transpiler/transpiler.ml

@@ -448,7 +448,7 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express
     let expr = Expression.make_tpl (E_literal f_literal , tv) in
     ok (expr , raw_input , output) in
   let%bind c_expr =
-    ok @@ Expression.make_tpl (E_capture_environment fv , c_tv) in
+    ok @@ Expression.make_tpl (E_environment_capture fv , c_tv) in
   let expr = Expression.pair f_expr c_expr in
   let tv = Mini_c.t_deep_closure c_env input_tv output_tv in
   ok @@ Expression.make_tpl (expr , tv)