Add '<-', a message send that yields the recipient

archetype-mode.el

@@ -140,8 +140,10 @@ All other single quotes (apostrophes, stray ticks) remain punctuation."
       (,val  . font-lock-constant-face)
       ;; Built-in identifiers
       (,blt  . font-lock-builtin-face)
-      ;; Message-send operators: --> (broadcast to class) and -> (send to object)
-      ("-->?" 0 ,op-face)
+      ;; Message-send operators: --> (broadcast to class), -> (send to object),
+      ;; and <- (send to object, yielding the object rather than the reply).
+      ;; "<-" is listed first so it wins over any shorter match.
+      ("<-\\|-->?" 0 ,op-face)
       ;; Assignment operators: := and the compound forms +:= -:= &:=
       ("[+\\-&]?:=" 0 ,op-face)))
   "Font-lock specification for `archetype-mode'.")
@@ -171,6 +173,7 @@ Syntax overview:
   object NAME  attr : value  methods  'MSG' : stmt  end
   'MESSAGE' -> object          # send a message, get return value
   'MESSAGE' --> class          # send to nearest ancestor class
+  object <- 'M1' <- 'M2'       # send for effect, get the object back
   expr := value                # assignment
   >>verbatim text here         # print exactly as written
 

src/Expression.cc

@@ -108,6 +108,7 @@ namespace archetype {
 
             case OP_SEND: return 6;
             case OP_PASS: return 6;
+            case OP_SEND_TO: return 6;
 
             case OP_EQ: return 5;
             case OP_NE: return 5;
@@ -484,6 +485,28 @@ namespace archetype {
                 return false;
             }
             bool result = true;
+
+            // "->" and "<-" share a precedence and both group to the left, so
+            // an unparenthesized mix of the two silently reassociates into
+            // nonsense:  (verb -> system <- 'X') sends 'X' to whatever object
+            // the reply happened to be.  The reading almost certainly meant is
+            // (verb -> (system <- 'X')), which puts the "<-" on the *right*
+            // side; only a left-hand child is ambiguous, so only that is
+            // refused.  This does also refuse a deliberate
+            // ((a -> b) <- c) -- send to whatever object came back -- which
+            // has to go through an intermediate attribute instead.
+            auto is_arrow = [](Keywords::Operators_e o) {
+                return o == OP_SEND or o == OP_PASS or o == OP_SEND_TO;
+            };
+            if (is_arrow(op())) {
+                if (auto left_arrow = dynamic_cast<const BinaryOperator*>(left_.get());
+                    left_arrow and is_arrow(left_arrow->op()) and
+                    (op() == OP_SEND_TO) != (left_arrow->op() == OP_SEND_TO)) {
+                    t.errorMessage("Cannot mix '->' and '<-' without parentheses");
+                    return false;
+                }
+            }
+
             switch (op()) {
                 case OP_DOT:
                     if (auto id_node = dynamic_cast<const IdentifierNode*>(right_.get())) {
@@ -671,6 +694,37 @@ namespace archetype {
                     break;
                 }
 
+                // The mirror image of OP_SEND in operand order, but not in
+                // value:  this yields the recipient, not the reply.  That is
+                // what lets sends chain -- (obj <- 'A' <- 'B') -- and what
+                // lets a stateful recipient be primed in place, as in
+                // (verb -> (system <- 'WHICH OBJECT')).
+                case OP_SEND_TO: {
+                    Value lv_o = left_->evaluate()->objectConversion();
+                    if (not lv_o->isDefined()) {
+                        // An undefined recipient quietly swallows the rest of
+                        // a chain, since every later <- then has an undefined
+                        // left side.  This is how OP_SEND degrades too.
+                        result = std::move(lv_o);
+                        break;
+                    }
+                    ObjectPtr recipient = Universe::instance().getObject(lv_o->getObject());
+                    if (not recipient) {
+                        result = make_unique<UndefinedValue>();
+                        break;
+                    }
+                    // Evaluated after the recipient, so that a chain sends in
+                    // the order written.
+                    Value rv_v = right_->evaluate()->valueConversion();
+                    if (recipient->isPrototype()) {
+                        Object::pass(recipient, std::move(rv_v));
+                    } else {
+                        Object::send(recipient, std::move(rv_v));
+                    }
+                    result = make_unique<ObjectValue>(recipient->id());
+                    break;
+                }
+
                 default:
                     if (is_binary(op())) {
                         throw logic_error("No binary operator evaluation written for " +

src/Keywords.cc

@@ -107,6 +107,15 @@ namespace archetype {
         OPERATOR(OP_WITHIN, "within");
         OPERATOR(OP_HEAD, "head");
         OPERATOR(OP_TAIL, "tail");
+
+        // The list above is in ASCII order, but only for the reader's
+        // convenience: the scanner looks operators up by exact string, so
+        // position carries no meaning to it.  Position does fix the
+        // enumerator's value, though, and those values are serialized, so a
+        // new operator is appended here rather than filed alphabetically.
+        // "<-" would otherwise belong between "<" and "<=", which would
+        // renumber OP_LE onward and break every existing .acx file.
+        OPERATOR(OP_SEND_TO, "<-");
     }
 
     Keywords::~Keywords() {

src/Keywords.hh

@@ -93,6 +93,12 @@ namespace archetype {
             OP_WITHIN,
             OP_HEAD,
             OP_TAIL,
+
+            // New operators go here, at the end.  These enumerators are the
+            // ints written into .acx files, so renumbering any of the ones
+            // above would invalidate every compiled game and save file.
+            OP_SEND_TO,
+
             NumOperators,
 
             // Kept outside of the range of valid operators, but

src/TestExpression.cc

@@ -120,6 +120,20 @@ namespace archetype {
         string actual8 = as_prefix(expr8);
         string expected8 = "(> (:= (. x i) (+ (. x i) 1)) 5)";
         ARCHETYPE_TEST_EQUAL(actual8, expected8);
+
+        // "<-" groups to the left, which is what lets it chain:  each send
+        // yields the recipient back for the next one to use.
+        Expression expr9 = make_expr_from_str("system <- 'BANNER' <- '='");
+        string actual9 = as_prefix(expr9);
+        string expected9 = "(<- (<- system 'BANNER') '=')";
+        ARCHETYPE_TEST_EQUAL(actual9, expected9);
+
+        // Parenthesized, "<-" lands on the right side of "->", so it primes
+        // the recipient rather than consuming the reply.
+        Expression expr10 = make_expr_from_str("verb -> (system <- 'WHICH OBJECT')");
+        string actual10 = as_prefix(expr10);
+        string expected10 = "(-> verb (<- system 'WHICH OBJECT'))";
+        ARCHETYPE_TEST_EQUAL(actual10, expected10);
     }
 
     void TestExpression::testEvaluation_() {
@@ -246,6 +260,20 @@ namespace archetype {
             expect("'hello' -> scratch = ABSENT", make_unique<BooleanValue>(false));
             expect("'hello' -> scratch ~= ABSENT", make_unique<BooleanValue>(true));
 
+            // "<-" yields the recipient, not the reply, so a chain of them
+            // stays anchored on the same object.  scratch.x has been climbing
+            // by one for every 'hello' sent above; these two send two more.
+            expect("scratch.x := 0", make_unique<NumericValue>(0));
+            expect("(scratch <- 'hello' <- 'hello') = scratch", make_unique<BooleanValue>(true));
+            expect("scratch.x", make_unique<NumericValue>(2));
+            // An unknown message is still a send; it just accomplishes nothing.
+            expect("(scratch <- 'never') = scratch", make_unique<BooleanValue>(true));
+            expect("scratch.x", make_unique<NumericValue>(2));
+            // An undefined recipient swallows the whole chain rather than
+            // throwing:  every later "<-" then has an undefined left side.
+            expect("nowhere <- 'hello' <- 'hello'", make_unique<UndefinedValue>());
+            expect("scratch.x", make_unique<NumericValue>(2));
+
         for (auto& p : testing_pairs) {
             Expression expr = make_expr_from_str(p.first);
             out() << "Testing: {" << p.first << "}" << endl;
@@ -273,6 +301,10 @@ namespace archetype {
             {
                 "\"Hello \" & \"world\"",
                 "(& \"Hello \" \"world\")"
+            },
+            {
+                "read -> (system <- 'SAVE STATE')",
+                "(-> read (<- system 'SAVE STATE'))"
             }
         };
         for (auto const& p : expressions) {
@@ -321,6 +353,26 @@ namespace archetype {
         ARCHETYPE_TEST(expr6 == nullptr);
         Expression expr7 = make_expr_from_str("('hello' -> world).tricky := 5");
         ARCHETYPE_TEST(expr7 != nullptr);
+
+        // "->" and "<-" share a precedence and both group left, so mixing them
+        // unparenthesized reassociates into something nobody means.  Refused
+        // rather than quietly obeyed.
+        Expression expr8 = make_expr_from_str("verb -> system <- 'WHICH OBJECT'");
+        ARCHETYPE_TEST(expr8 == nullptr);
+        Expression expr9 = make_expr_from_str("system <- 'WHICH OBJECT' -> verb");
+        ARCHETYPE_TEST(expr9 == nullptr);
+        Expression expr10 = make_expr_from_str("message --> parent <- 'DONE'");
+        ARCHETYPE_TEST(expr10 == nullptr);
+
+        // Parentheses say which reading was meant, and both readings are legal.
+        Expression expr11 = make_expr_from_str("verb -> (system <- 'WHICH OBJECT')");
+        ARCHETYPE_TEST(expr11 != nullptr);
+
+        // Chains of a single arrow are never ambiguous.
+        Expression expr12 = make_expr_from_str("system <- 'BANNER' <- '='");
+        ARCHETYPE_TEST(expr12 != nullptr);
+        Expression expr13 = make_expr_from_str("'GENERATE' -> namesakes -> system");
+        ARCHETYPE_TEST(expr13 != nullptr);
     }
 
     void TestExpression::testListLiterals_() {

src/TestSystemObject.cc

@@ -156,9 +156,63 @@ namespace archetype {
         ARCHETYPE_TEST(are_equal);
     }
 
+    // "<-" exists mainly for system's protocols, which are sequences of
+    // messages sent for effect.  These check the two shapes that buys:  a
+    // chain of effects, and a selector primed in place so that the argument's
+    // reply can be used in the same expression.
+    void TestSystemObject::testArrowSequencing_() {
+        Universe::destroy();
+
+        // The whole sorter protocol as one chain.  Each "<-" hands system back
+        // to the next, so the messages arrive in written order.
+        Statement stmt = make_stmt_from_str(
+            "system <- 'INIT SORTER' <- \"dog\" <- \"Ajax\" <- \"cat\" <- 'CLOSE SORTER'"
+        );
+        stmt->execute();
+        deque<string> expected = {"Ajax", "cat", "dog"};
+        stmt = make_stmt_from_str("'NEXT SORTED' -> system");
+        for (auto const& s : expected) {
+            Value ans = stmt->execute()->stringConversion();
+            ARCHETYPE_TEST(ans->isDefined());
+            ARCHETYPE_TEST_EQUAL(ans->getString(), s);
+        }
+        ARCHETYPE_TEST(not stmt->execute()->isDefined());
+
+        // A chain evaluates to the recipient, so it can be sent to again.
+        Value chained = make_stmt_from_str("(system <- 'INIT SORTER') = system")->execute();
+        ARCHETYPE_TEST(chained->isTrueEnough());
+        make_stmt_from_str("'CLOSE SORTER' -> system")->execute();
+
+        // 'WHICH OBJECT' followed by its argument is one logical operation,
+        // but it took two statements to write before.  This only comes out
+        // right because "->" evaluates its message first and its recipient
+        // second:  system is put into WHICH_OBJECT state after "grab" is
+        // evaluated and immediately before the send.
+        TokenStream t1(make_source_from_str("program1", program1));
+        Universe::instance().make(t1);
+        make_stmt_from_str(
+            "{'OPEN PARSER' -> system;"
+            "'BUILD' -> take;"
+            "'BUILD' -> money;"
+            "'CLOSE PARSER' -> system}"
+        )->execute();
+
+        int take_obj_id = Universe::instance().getObject("take")->id();
+        Value one_liner = make_stmt_from_str("\"grab\" -> (system <- 'WHICH OBJECT')")->execute();
+        Value take_obj = make_unique<ObjectValue>(take_obj_id);
+        ARCHETYPE_TEST(one_liner->isSameValueAs(take_obj));
+
+        // Same answer as the two-statement form it replaces.
+        Value two_statements = make_stmt_from_str(
+            "{'WHICH OBJECT' -> system; \"grab\" -> system}"
+        )->execute();
+        ARCHETYPE_TEST(two_statements->isSameValueAs(take_obj));
+    }
+
     void TestSystemObject::runTests_() {
         testSorting_();
         testParsing_();
         testEmptyPhraseNeverMatches_();
+        testArrowSequencing_();
     }
 }

src/TestSystemObject.hh

@@ -18,6 +18,7 @@ namespace archetype {
         void testSorting_();
         void testParsing_();
         void testEmptyPhraseNeverMatches_();
+        void testArrowSequencing_();
     protected:
         virtual void runTests_() override;
     public: