Michelson: change semantics of SOURCE and add SENDER

docs/whitedoc/michelson.rst

@@ -1385,8 +1385,24 @@ contract, unit for an account.
     > CONTRACT / addr : S  =>  None : S
         otherwise
 
--  ``SOURCE``: Push the source contract of the current
+-  ``SOURCE``: Push the contract that initiated the current
-   transaction.
+   transaction, i.e. the contract that paid the fees and
+   storage cost, and whose manager signed the operation
+   that was sent on the blockchain. Note that since
+   ``TRANSFER_TOKENS`` instructions can be chained,
+   ``SOURCE`` and ``SENDER`` are not necessarily the same.
+
+::
+
+    :: 'S   ->   address : 'S
+
+-  ``SENDER``: Push the contract that initiated the current
+   internal transaction. It may be the ``SOURCE``, but may
+   also not if the source sent an order to an intermediate
+   smart contract, which then called the current contract.
+   To make sure that ``SENDER`` is the ``SOURCE``, either
+   compare them, or make sure that ``SENDER`` is the implicit
+   account of its ``MANAGER``.
 
 ::
 
@@ -2035,6 +2051,7 @@ The instructions which accept at most one variable annotation are:
    H
    STEPS_TO_QUOTA
    SOURCE
+   SENDER
    SELF
    CAST
    RENAME
@@ -2299,6 +2316,8 @@ A similar mechanism is used for context dependent instructions:
 
    SOURCE  :: 'S   ->   @source address : 'S
 
+   SENDER  :: 'S   ->   @sender address : 'S
+
    SELF  :: 'S   ->   @self contract 'p : 'S
 
    AMOUNT  :: 'S   ->   @amount tez : 'S
@@ -2929,7 +2948,8 @@ XII - Full grammar
       | H
       | HASH_KEY
       | STEPS_TO_QUOTA
-      | SOURCE <type> <type>
+      | SOURCE
+      | SENDER
     <type> ::=
       | <comparable type>
       | key

src/bin_client/test/contracts/cps_fact.tz

@@ -1,7 +1,7 @@
 storage nat ;
 parameter nat ;
 code { UNPAIR ;
-       DIP { SELF ; ADDRESS ; SOURCE;
+       DIP { SELF ; ADDRESS ; SENDER;
              IFCMPEQ {} { DROP ; PUSH @storage nat 1 } };
        DUP ;
        PUSH nat 1 ;

src/bin_client/test/contracts/create_account.tz

@@ -7,6 +7,6 @@ code { CAR;
            DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ;
                  NIL operation ; SWAP ; CONS } ;
            CONS ; NONE (contract unit) ; SWAP ; PAIR }
-         { SELF ; ADDRESS ; SOURCE ; IFCMPNEQ { FAIL } {} ;
+         { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ;
            CONTRACT unit ; DUP ; IF_SOME { DROP } { FAIL } ;
            NIL operation ; PAIR } } ;

src/bin_client/test/contracts/create_contract.tz

@@ -12,7 +12,7 @@ code { CAR;
            DIP { RIGHT key_hash ; DIP { SELF ; PUSH mutez 0 } ; TRANSFER_TOKENS ;
                  NIL operation ; SWAP ; CONS } ;
            CONS ; UNIT ; SWAP ; PAIR }
-         { SELF ; ADDRESS ; SOURCE ; IFCMPNEQ { FAIL } {} ;
+         { SELF ; ADDRESS ; SENDER ; IFCMPNEQ { FAIL } {} ;
            CONTRACT string ; IF_SOME {} { FAIL } ;
            PUSH mutez 0 ; PUSH string "abcdefg" ; TRANSFER_TOKENS ;
            NIL operation; SWAP; CONS ; UNIT ; SWAP ; PAIR } };

src/bin_client/test/contracts/forward.tz

@@ -112,7 +112,7 @@ code
                              IF { # Between T + 24 and T + 48
                                   # We accept only delivery notifications, from W
                                   DUP ; CDDDDDR ; MANAGER ; # W
-                                  SOURCE ; MANAGER ; IF_NONE { FAIL } {} ;
+                                  SENDER ; MANAGER ; IF_NONE { FAIL } {} ;
                                   COMPARE ; NEQ ;
                                   IF { FAIL } {} ; # fail if not the warehouse
                                   DUP ; CAR ; # we must receive (Right amount)

src/bin_client/test/contracts/vote_for_delegate.tz

@@ -3,10 +3,10 @@ storage (pair
            (pair %mgr1 (address %addr) (option %key key_hash))
            (pair %mgr2 (address %addr) (option %key key_hash))) ;
 code { # Update the storage
-       DUP ; CDAAR %addr @%; SOURCE ; PAIR %@ %@; UNPAIR;
+       DUP ; CDAAR %addr @%; SENDER ; PAIR %@ %@; UNPAIR;
        IFCMPEQ
          { UNPAIR ; SWAP ; SET_CADR %key @changed_mgr1_key }
-         { DUP ; CDDAR ; SOURCE ;
+         { DUP ; CDDAR ; SENDER ;
            IFCMPEQ
              { UNPAIR ; SWAP ; SET_CDDR %key }
              { FAIL } } ;

src/proto_alpha/lib_protocol/src/alpha_context.mli

@@ -234,6 +234,7 @@ module Script : sig
     | I_SIZE
     | I_SOME
     | I_SOURCE
+    | I_SENDER
     | I_SELF
     | I_STEPS_TO_QUOTA
     | I_SUB

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml

@@ -83,6 +83,7 @@ type prim =
   | I_SIZE
   | I_SOME
   | I_SOURCE
+  | I_SENDER
   | I_SELF
   | I_STEPS_TO_QUOTA
   | I_SUB
@@ -210,6 +211,7 @@ let string_of_prim = function
   | I_SIZE -> "SIZE"
   | I_SOME -> "SOME"
   | I_SOURCE -> "SOURCE"
+  | I_SENDER -> "SENDER"
   | I_SELF -> "SELF"
   | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA"
   | I_SUB -> "SUB"
@@ -318,6 +320,7 @@ let prim_of_string = function
   | "SIZE" -> ok I_SIZE
   | "SOME" -> ok I_SOME
   | "SOURCE" -> ok I_SOURCE
+  | "SENDER" -> ok I_SENDER
   | "SELF" -> ok I_SELF
   | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA
   | "SUB" -> ok I_SUB
@@ -471,6 +474,7 @@ let prim_encoding =
     ("SIZE", I_SIZE) ;
     ("SOME", I_SOME) ;
     ("SOURCE", I_SOURCE) ;
+    ("SENDER", I_SENDER) ;
     ("SELF", I_SELF) ;
     ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ;
     ("SUB", I_SUB) ;

src/proto_alpha/lib_protocol/src/michelson_v1_primitives.mli

@@ -81,6 +81,7 @@ type prim =
   | I_SIZE
   | I_SOME
   | I_SOURCE
+  | I_SENDER
   | I_SELF
   | I_STEPS_TO_QUOTA
   | I_SUB

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -707,6 +707,9 @@ let rec interp
               | Unaccounted -> Z.of_string "99999999" in
             logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
         | Source, rest ->
+            Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
+            logged_return (Item (payer, rest), ctxt)
+        | Sender, rest ->
             Lwt.return (Gas.consume ctxt Interp_costs.source) >>=? fun ctxt ->
             logged_return (Item (source, rest), ctxt)
         | Self t, rest ->

src/proto_alpha/lib_protocol/src/script_ir_annot.ml

@@ -17,6 +17,7 @@ let default_amount_annot = Some (`Var_annot "amount")
 let default_balance_annot = Some (`Var_annot "balance")
 let default_steps_annot = Some (`Var_annot "steps")
 let default_source_annot = Some (`Var_annot "source")
+let default_sender_annot = Some (`Var_annot "sender")
 let default_self_annot = Some (`Var_annot "self")
 let default_arg_annot = Some (`Var_annot "arg")
 let default_param_annot = Some (`Var_annot "parameter")

src/proto_alpha/lib_protocol/src/script_ir_annot.mli

@@ -17,6 +17,7 @@ val default_amount_annot : var_annot option
 val default_balance_annot : var_annot option
 val default_steps_annot : var_annot option
 val default_source_annot : var_annot option
+val default_sender_annot : var_annot option
 val default_self_annot : var_annot option
 val default_arg_annot : var_annot option
 val default_param_annot : var_annot option

src/proto_alpha/lib_protocol/src/script_ir_translator.ml

@@ -206,6 +206,7 @@ let number_of_generated_growing_types : type b a. (b, a) instr -> int = function
   | H _ -> 0
   | Steps_to_quota -> 0
   | Source -> 0
+  | Sender -> 0
   | Self _ -> 1
   | Amount -> 0
   | Set_delegate -> 0
@@ -294,6 +295,7 @@ let namespace = function
   | I_SIZE
   | I_SOME
   | I_SOURCE
+  | I_SENDER
   | I_SELF
   | I_STEPS_TO_QUOTA
   | I_SUB
@@ -2380,6 +2382,11 @@ and parse_instr
         parse_var_annot loc annot ~default:default_source_annot >>=? fun annot ->
         typed ctxt loc Source
           (Item_t (Address_t None, stack, annot))
+    | Prim (loc, I_SENDER, [], annot),
+      stack ->
+        parse_var_annot loc annot ~default:default_sender_annot >>=? fun annot ->
+        typed ctxt loc Sender
+          (Item_t (Address_t None, stack, annot))
     | Prim (loc, I_SELF, [], annot),
       stack ->
         parse_var_annot loc annot ~default:default_self_annot >>=? fun annot ->
@@ -2404,7 +2411,7 @@ and parse_instr
                  | I_MANAGER | I_TRANSFER_TOKENS | I_CREATE_ACCOUNT
                  | I_CREATE_CONTRACT | I_SET_DELEGATE | I_NOW
                  | I_IMPLICIT_ACCOUNT | I_AMOUNT | I_BALANCE
-                 | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE
+                 | I_CHECK_SIGNATURE | I_HASH_KEY | I_SOURCE | I_SENDER
                  | I_H | I_STEPS_TO_QUOTA | I_ADDRESS
                  as name), (_ :: _ as l), _), _ ->
         fail (Invalid_arity (loc, name, 0, List.length l))
@@ -2478,7 +2485,7 @@ and parse_instr
             I_PUSH ; I_NONE ; I_LEFT ; I_RIGHT ; I_NIL ;
             I_EMPTY_SET ; I_DIP ; I_LOOP ;
             I_IF_NONE ; I_IF_LEFT ; I_IF_CONS ;
-            I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SELF ; I_LAMBDA ]
+            I_EMPTY_MAP ; I_IF ; I_SOURCE ; I_SENDER ; I_SELF ; I_LAMBDA ]
 
 and parse_contract
   : type arg. context -> Script.location -> arg ty -> Contract.t ->

src/proto_alpha/lib_protocol/src/script_typed_ir.ml

@@ -348,6 +348,8 @@ and ('bef, 'aft) instr =
       ('rest, n num * 'rest) instr
   | Source :
       ('rest, Contract.t * 'rest) instr
+  | Sender :
+      ('rest, Contract.t * 'rest) instr
   | Self : 'p ty ->
     ('rest, 'p typed_contract * 'rest) instr
   | Amount :