Michelson: change semantics of CONCAT

src/bin_client/test/contracts/concat.tz

@@ -1,8 +1,7 @@
 parameter string;
 storage string;
-code {DUP;                      # We're going to need both the storage and parameter
+code { DUP;
-      CAR;                      # Get the parameter
+       DIP { CDR ; NIL string ; SWAP ; CONS } ;
-      DIP{CDR};                 # Get the storage value
+       CAR ; CONS ;
-      SWAP;                     # Get the order we want (this is optional)
+       CONCAT;
-      CONCAT;                   # Concatenate the strings
+       NIL operation; PAIR}
-      NIL operation; PAIR}      # Match the calling convention

src/bin_client/test/contracts/concat_hello.tz

@@ -1,4 +1,7 @@
 parameter (list string);
 storage (list string);
 code{ CAR;
-      MAP { PUSH @hello string "Hello "; CONCAT }; NIL operation; PAIR};
+      MAP { NIL string ; SWAP ; CONS ;
+            PUSH @hello string "Hello "; CONS ;
+            CONCAT };
+      NIL operation; PAIR};

src/bin_client/test/contracts/concat_list.tz

@@ -1,5 +1,5 @@
 parameter (list string);
 storage string;
 code {CAR; PUSH string ""; SWAP;
-      ITER {SWAP; CONCAT};
+      ITER {SWAP; DIP{NIL string; SWAP; CONS}; CONS; CONCAT};
       NIL operation; PAIR};

src/bin_client/test/contracts/exec_concat.tz

@@ -1,5 +1,7 @@
 parameter string;
 storage string;
 code {CAR;
-      LAMBDA string string {PUSH string "_abc"; SWAP; CONCAT};
+      LAMBDA string string
+             {PUSH string "_abc"; NIL string ;
+              SWAP ; CONS ; SWAP ; CONS ; CONCAT};
       SWAP; EXEC; NIL operation; PAIR};

src/bin_client/test/contracts/list_iter2.tz

@@ -1,5 +1,3 @@
 parameter (list string);
 storage string;
-code { CAR; PUSH string ""; SWAP;
+code { UNPAIR ; SWAP ; CONS ; CONCAT; NIL operation; PAIR}
-       ITER { CONCAT };
-       NIL operation; PAIR}

src/bin_client/test/test_contracts.sh

@@ -114,8 +114,8 @@ assert_storage $contract_dir/list_map_block.tz '{0}' '{ 1 ; 2 ; 3 ; 0 }' '{ 1 ;
 assert_storage $contract_dir/list_iter.tz 0 '{ 10 ; 2 ; 1 }' 20
 assert_storage $contract_dir/list_iter.tz 0 '{ 3 ; 6 ; 9 }' 162
 
-assert_storage $contract_dir/list_iter2.tz '"?"' '{ "a" ; "b" ; "c" }' '"cba"'
+assert_storage $contract_dir/list_iter2.tz '"abc"' '{ "d" ; "e" ; "f" }' '"abcdef"'
-assert_storage $contract_dir/list_iter2.tz '"?"' '{}' '""'
+assert_storage $contract_dir/list_iter2.tz '"abc"' '{}' '"abc"'
 
 
 # Identity on sets

src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml

@@ -53,8 +53,13 @@ module Cost_of = struct
   let zint z =
     alloc_bits_cost (Z.numbits z)
 
-  let concat s1 s2 =
+  let concat cost length ss =
-    string (String.length s1 + String.length s2)
+    let rec cum acc = function
+      | [] -> acc
+      | s :: ss -> cum (cost (length s) +@ acc) ss in
+    cum free ss
+
+  let concat_string ss = concat string String.length ss
 
   (* Cost per cycle of a loop, fold, etc *)
   let loop_cycle = step_cost 2

src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli

@@ -38,7 +38,7 @@ module Cost_of : sig
   val cons : Gas.cost
   val variant_no_data : Gas.cost
   val branch : Gas.cost
-  val concat : string -> string -> Gas.cost
+  val concat_string : string list -> Gas.cost
   val map_mem :
     'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost
   val map_to_list :

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -415,8 +415,10 @@ let rec interp
             consume_gas_binop descr (Script_timestamp.diff, t1, t2)
               Interp_costs.diff_timestamps rest ctxt
         (* string operations *)
-        | Concat, Item (x, Item (y, rest)) ->
+        | Concat, Item (ss, rest) ->
-            consume_gas_binop descr ((^), x, y) Interp_costs.concat rest ctxt
+            Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt ->
+            let s = String.concat "" ss in
+            logged_return (Item (s, rest), ctxt)
         (* currency operations *)
         | Add_tez, Item (x, Item (y, rest)) ->
             Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt ->

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -2111,9 +2111,8 @@ and parse_instr
           (Item_t (Int_t tname, rest, annot))
     (* string operations *)
     | Prim (loc, I_CONCAT, [], annot),
-      Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ->
+      Item_t (List_t (String_t tname, _), rest, list_annot) ->
-        parse_var_annot loc annot >>=? fun annot ->
+        parse_var_annot ~default:list_annot loc annot >>=? fun annot ->
-        Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname ->
         typed ctxt loc Concat
           (Item_t (String_t tname, rest, annot))
     (* currency operations *)
@@ -2611,10 +2610,10 @@ and parse_instr
         get_toplevel_type tc_context
     (* Primitive parsing errors *)
     | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT
-                 | I_PAIR | I_CAR | I_CDR | I_CONS
+                 | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT
                  | I_MEM | I_UPDATE | I_MAP
                  | I_GET | I_EXEC | I_FAILWITH | I_SIZE
-                 | I_CONCAT | I_ADD | I_SUB
+                 | I_ADD | I_SUB
                  | I_MUL | I_EDIV | I_OR | I_AND | I_XOR
                  | I_NOT
                  | I_ABS | I_NEG | I_LSL | I_LSR
@@ -2643,12 +2642,12 @@ and parse_instr
     (* Stack errors *)
     | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV
                  | I_AND | I_OR | I_XOR | I_LSL | I_LSR
-                 | I_CONCAT | I_COMPARE as name), [], _),
+                 | I_COMPARE as name), [], _),
       Item_t (ta, Item_t (tb, _, _), _) ->
         Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) ->
         Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) ->
         fail (Undefined_binop (loc, name, ta, tb))
-    | Prim (loc, (I_NEG | I_ABS | I_NOT
+    | Prim (loc, (I_NEG | I_ABS | I_NOT | I_CONCAT
                  | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name),
             [], _),
       Item_t (t, _, _) ->
@@ -2683,7 +2682,7 @@ and parse_instr
                  | I_GET | I_MEM | I_EXEC
                  | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL
                  | I_EDIV | I_AND | I_OR | I_XOR
-                 | I_LSL | I_LSR | I_CONCAT as name), _, _),
+                 | I_LSL | I_LSR as name), _, _),
       stack ->
         serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) ->
         fail (Bad_stack (loc, name, 2, stack))

src/proto_alpha/lib_protocol/src/script_typed_ir.ml

@@ -203,7 +203,7 @@ and ('bef, 'aft) instr =
       ('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr
   (* string operations *)
   | Concat :
-      (string * (string * 'rest), string * 'rest) instr
+      (string list * 'rest, string * 'rest) instr
   (* timestamp operations *)
   | Add_seconds_to_timestamp :
       (z num * (Script_timestamp.t * 'rest),