add assign.macro for defining assignment operators

Support for assignment is built into `.`, `[]`, field access, and
proprty access. Previously, those places recognized `:=` specifically,
but now they can access operators defined with `assign.macro`.

An assignment macro can expand to a use of another assignment macro,
or it can use `assign_meta.unpack_left` to get an accessor function
and mutator function (and a name to use as the inferred name for the
right-hand side). It can then use the accessor and mutator in whatever
combination, such as using both for implement a C-like `+=` operator,
and return it by packing with `assign_meta.pack_assignment`.

rhombus/private/assign-macro.rkt

@@ -0,0 +1,135 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     syntax/parse/pre
+                     enforest/proc-name
+                     enforest/transformer-result
+                     "pack.rkt"
+                     "tail-returner.rkt"
+                     "name-root.rkt"
+                     (submod "syntax-class-primitive.rkt" for-syntax-class)
+                     (submod "syntax-class-primitive.rkt" for-syntax-class-syntax)
+                     (for-syntax racket/base))
+         "name-root.rkt"
+         "macro-macro.rkt"
+         "parse.rkt"
+         (submod "assign.rkt" for-assign)
+         (submod "syntax-object.rkt" for-quasiquote))
+
+(provide (for-space rhombus/namespace
+                    assign)
+         (for-syntax
+          (for-space rhombus/namespace
+                     assign_meta)))
+
+(define-name-root assign
+  #:fields
+  (macro))
+
+(begin-for-syntax
+  (define-name-root assign_meta
+    #:fields
+    (unpack_left
+     pack_assignment
+     AssignParsed)))
+
+(define-operator-definition-transformer macro
+  'macro
+  #f
+  #'#f
+  #'make-assign-operator
+  #'#f)
+
+(define-for-syntax (extract-assignment form proc)
+  (syntax-parse (if (syntax? form)
+                    (unpack-group form proc #f)
+                    #'#f)
+    #:datum-literals (parsed group assignment left-hand-side)
+    [(group (parsed (assignment e)) . tail) (values #'e #'tail)]
+    [(group (parsed (left-hand-side ref set rhs-name)) ~! . tail)
+     #:with assign::assign-op-seq #'tail
+     #:do [(define op (attribute assign.op))]
+     (build-assign op
+                   #'assign.name
+                   #'ref
+                   #'set
+                   #'rhs-name
+                   #'assign.tail)]
+    [_ (raise-result-error (proc-name proc) "Assign_Syntax" form)]))
+
+(define-for-syntax (wrap-parsed stx)
+  #`(parsed #,stx))
+
+(define-for-syntax (make-assign-operator name prec protocol proc assc)
+  (make-assign-infix-operator
+   name
+   prec
+   assc
+   protocol
+   (if (eq? protocol 'macro)
+       (lambda (ref set tail rhs-name)
+         (define-values (form new-tail)
+           (tail-returner
+            proc
+            (syntax-parse tail
+              [(head . tail) (proc (wrap-parsed #`(left-hand-side #,ref #,set #,rhs-name))
+                                   (pack-tail #'tail #:after #'head)
+                                   #'head)])))
+         (define-values (ex-form more-tail)
+           (extract-assignment form proc))
+         (check-transformer-result ex-form
+                                   (cond
+                                     [(null? (syntax-e more-tail))
+                                      (unpack-tail new-tail proc #f)]
+                                     [(null? (syntax-e new-tail))
+                                      (unpack-tail more-tail proc #f)]
+                                     [else
+                                      (unpack-tail (append (syntax->list more-tail) tail) proc #f)])
+                                   proc))
+       (lambda (ref set form2 stx rhs-name)
+         (define-values (form tail)
+           (extract-assignment (proc (wrap-parsed #`(left-hand-side #,ref #,set #,rhs-name))
+                                     (wrap-parsed form2)
+                                     stx)
+                               proc))
+         (unless (null? (syntax-e tail))
+           (raise-syntax-error #f "expected empty tail" tail))
+         form))))
+
+(define-for-syntax (unpack_left stx)
+  (syntax-parse (unpack-term stx 'assign_meta.unpack_left #f)
+    #:datum-literals (parsed left-hand-side)
+    [(parsed (left-hand-side ref set rhs-name))
+     (values #'(parsed ref)
+             #'(parsed set)
+             #'rhs-name)]))
+
+(define-for-syntax (pack_assignment stx)
+  #`(parsed (assignment
+             (rhombus-expression #,(unpack-group stx 'assign_meta.pack_expression #f)))))
+
+(begin-for-syntax
+  (define-syntax-class (:assign-parsed ref set rhs-name)
+    #:attributes (parsed tail)
+    #:datum-literals (group)
+    (pattern (group . assign::assign-op-seq)
+             #:do [(define op (attribute assign.op))
+                   (define-values (assign-expr tail) (build-assign
+                                                      op
+                                                      #'assign.name
+                                                      #`(rhombus-expression #,(unpack-group ref 'assign_meta.AssignParsed #f))
+                                                      #`(rhombus-expression #,(unpack-group set 'assign_meta.AssignParsed #f))
+                                                      (if (identifier? rhs-name)
+                                                          rhs-name
+                                                          (raise-argument-error 'assign_meta.AssignParsed
+                                                                                "Identifier"
+                                                                                rhs-name))
+                                                      #'assign.tail))]
+             #:attr parsed assign-expr
+             #:attr tail tail))
+  (define-syntax-class-syntax AssignParsed (make-syntax-class
+                                            #':assign-parsed
+                                            #:arity 8
+                                            #:kind 'group
+                                            #:fields #'((parsed #f parsed 0 unpack-parsed*)
+                                                        (tail #f tail tail unpack-tail-list*))
+                                            #:root-swap '(parsed . group))))

rhombus/private/assign.rkt

@@ -1,15 +1,58 @@
 #lang racket/base
 (require (for-syntax racket/base
                      syntax/parse/pre
+                     enforest/property
                      enforest/syntax-local
+                     enforest/hier-name-parse
+                     enforest/operator
+                     "name-path-op.rkt"
                      "annotation-string.rkt")
          "binding.rkt"
-         "expression.rkt")
+         "expression.rkt"
+         "name-root-space.rkt"
+         "name-root-ref.rkt"
+         "parse.rkt")
 
 (provide :=
          (for-space rhombus/bind
                     mutable))
 
+(module+ for-assign
+  (provide (for-syntax make-assign-infix-operator
+                       build-assign
+                       assign-infix-operator-ref
+                       :assign-op-seq)))
+
+(begin-for-syntax
+  (property assign-infix-operator expression-infix-operator (assign-proc))
+
+  (define-syntax-class :assign-op-seq
+    #:description "assignment operation"
+    #:attributes (op name tail)
+    (pattern (~var name (:hier-name-seq in-name-root-space in-expression-space name-path-op name-root-ref))
+             #:do [(define op (syntax-local-value* #'name.name assign-infix-operator-ref))]
+             #:when op
+             #:attr op op
+             #:attr tail #'name.tail))
+
+  (define (build-assign/automatic proc self-stx ref set rhs-name rhs)
+    (proc ref set rhs self-stx rhs-name))
+
+  (define (build-assign/macro proc self-stx ref set rhs-name tail)
+    (proc ref set (cons self-stx tail) rhs-name))
+
+  (define (build-assign op self-stx ref set rhs-name tail)
+    (cond
+      [(eq? (operator-protocol op) 'automatic)
+       (syntax-parse #`(group . #,tail)
+         [(~var e (:infix-op+expression+tail (operator-name op)))
+          (values (build-assign/automatic (assign-infix-operator-assign-proc op) self-stx ref set rhs-name
+                                          #`(let ([#,rhs-name e.parsed])
+                                              #,rhs-name))
+                  #'e.tail)])]
+      [else
+       (build-assign/macro (assign-infix-operator-assign-proc op) self-stx ref set rhs-name tail)])))
+
 (define-binding-syntax mutable
   (binding-transformer
    (lambda (stx)
@@ -57,18 +100,52 @@
     #:property prop:rename-transformer (struct-field-index id))
   (define (mutable-variable-ref v) (and (mutable-variable? v) v)))
 
+(define-for-syntax (make-assign-infix-operator name prec assc protocol proc)
+  (define (get-mv form1 self-stx)
+    (define mv (and (identifier? form1)
+                    (syntax-local-value* form1 mutable-variable-ref)))
+    (unless mv
+      (raise-syntax-error #f
+                          "left-hand argument is not a mutable identifier"
+                          self-stx))
+    mv)
+  (assign-infix-operator
+   name
+   prec
+   protocol
+   (if (eq? protocol 'automatic)
+       (lambda (form1 form2 self-stx)
+         (define mv (get-mv form1 self-stx))
+         #`(let ([#,form1 #,form2]) ; using `form1` here provides a name to `form2`
+             #,(build-assign/automatic proc
+                                       self-stx
+                                       #`(lambda ()
+                                           #,(mutable-variable-id mv))
+                                       #`(lambda (v)
+                                           (set! #,(mutable-variable-id mv) v))
+                                       form1
+                                       form1)))
+       (lambda (form1 tail)
+         (syntax-parse tail
+           [(head . tail)
+            (define self-stx #'head)
+            (define mv (get-mv form1 self-stx))
+            (build-assign/macro proc
+                                self-stx
+                                #`(lambda ()
+                                    #,(mutable-variable-id mv))
+                                #`(lambda (v)
+                                    (set! #,(mutable-variable-id mv) v))
+                                form1
+                                #'tail)])))
+   assc
+   proc))
+
 (define-syntax :=
-  (expression-infix-operator
+  (make-assign-infix-operator
    (expr-quote :=)
    '((default . weaker))
+   'left
    'automatic
-   (lambda (form1 form2 self-stx)
-     (define mv (and (identifier? form1)
-                     (syntax-local-value* form1 mutable-variable-ref)))
-     (unless mv
-       (raise-syntax-error #f
-                           "left-hand argument is not a mutable identifier"
-                           self-stx))
-     #`(let ([#,form1 #,form2])
-         (set! #,(mutable-variable-id mv) #,form1)))
-   'left))
+   (lambda (left-ref-stx left-assign-stx right-stx self-stx rhs-name)
+     #`(#,left-assign-stx #,right-stx))))

rhombus/private/bind-macro.rkt

@@ -382,7 +382,7 @@
                     (unpack-group form proc #f)
                     #'#f)
     [b::binding #'b.parsed]
-    [_ (raise-result-error (proc-name proc) "binding?" form)]))
+    [_ (raise-result-error (proc-name proc) "Binding_Syntax" form)]))
 
 (define-for-syntax (make-binding-infix-operator name prec protocol proc assc)
   (binding-infix-operator

rhombus/private/class-dot.rkt

@@ -20,7 +20,7 @@
                   in-repetition-space
                   repetition-transformer
                   identifier-repetition-use)
-         "assign.rkt"
+         (submod "assign.rkt" for-assign) (only-in "assign.rkt" :=)
          "op-literal.rkt"
          "name-root.rkt"
          "parse.rkt"
@@ -321,40 +321,35 @@
   (unless desc (error "cannot find annotation binding for instance dot provider"))
   (define (do-field fld)
     (define accessor-id (field-desc-accessor-id fld))
-    (define-values (op-id assign-rhs new-tail)
-      (syntax-parse tail
-        [(_:::=-expr . tail)
-         #:when (syntax-e (field-desc-mutator-id fld))
-         #:with (~var e (:infix-op+expression+tail #':=)) #'(group . tail)
-         (values (field-desc-mutator-id fld)
-                 #'e.parsed
-                 #'e.tail)]
-        [_
-         (values accessor-id
-                 #f
-                 tail)]))
-    (define e (datum->syntax (quote-syntax here)
-                             (append (list (relocate field-id op-id) form1)
-                                     (if assign-rhs
-                                         (list field-id)
-                                         null))
-                             (span-srcloc form1 field-id)
-                             #'dot))
-    (define full-e
-      (cond
-        [assign-rhs #`(let ([#,field-id #,assign-rhs])
-                        #,e)]
-        [else e]))
-
-    (define static-infos (field-desc-static-infos fld))
-    (define more-static-infos (syntax-local-static-info form1 accessor-id))
-    (define all-static-infos (if more-static-infos
-                                 (datum->syntax #f
-                                                (append (syntax->list more-static-infos)
-                                                        static-infos))
-                                 static-infos))
-    (success (wrap-static-info* full-e all-static-infos)
-             new-tail))
+    (syntax-parse tail
+      [assign::assign-op-seq
+       #:when (syntax-e (field-desc-mutator-id fld))
+       (define-values (assign-expr tail) (build-assign
+                                          (attribute assign.op)
+                                          #'assign.name
+                                          #`(lambda ()
+                                              (#,(relocate field-id accessor-id) obj))
+                                          #`(lambda (v)
+                                              (#,(field-desc-mutator-id fld) obj v))
+                                          #'obj
+                                          #'assign.tail))
+       (success #`(let ([obj #,form1])
+                    #,assign-expr)
+                tail)]
+      [_
+       (define e (datum->syntax (quote-syntax here)
+                                (list (relocate field-id accessor-id) form1)
+                                (span-srcloc form1 field-id)
+                                #'dot))
+       (define static-infos (field-desc-static-infos fld))
+       (define more-static-infos (syntax-local-static-info form1 accessor-id))
+       (define all-static-infos (if more-static-infos
+                                    (datum->syntax #f
+                                                   (append (syntax->list more-static-infos)
+                                                           static-infos))
+                                    static-infos))
+       (success (wrap-static-info* e all-static-infos)
+                tail)]))
   (define (do-method pos/id* ret-info-id nonfinal? property? shape-arity)
     (define-values (args new-tail)
       (if property?