From b67f5e71e69f880e0b8732c72acce579dfbd1023 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Thu, 26 Jan 2012 13:19:06 -0700
Subject: [PATCH] [honu] add moere assignment operators

---
 collects/honu/core/main.rkt             |  1 +
 collects/honu/core/private/literals.rkt |  2 +-
 collects/honu/core/private/operator.rkt | 39 ++++++++++++++++---------
 collects/honu/core/private/parse2.rkt   |  5 +++-
 collects/honu/core/read.rkt             |  3 +-
 5 files changed, 33 insertions(+), 17 deletions(-)

diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt
index 74ae807a90..74d709649c 100644
--- a/collects/honu/core/main.rkt
+++ b/collects/honu/core/main.rkt
@@ -65,6 +65,7 @@
                                    [honu-structure struct]
                                    [honu-syntax syntax]
                                    [honu-equal =]
+                                   [honu-+= +=]
                                    [literal:honu-prefix prefix]
                                    [literal:honu-then then]
                                    [literal:colon %colon]
diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt
index cf96c28ce4..5adca0a613 100644
--- a/collects/honu/core/private/literals.rkt
+++ b/collects/honu/core/private/literals.rkt
@@ -16,7 +16,7 @@
 (define-literal honu-return)
 (define-literal semicolon)
 (define-literal honu-|| honu-%
-                honu-+= honu--= honu-*= honu-/= honu-%=
+                honu-%=
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> 
                 honu-!=
diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt
index 1289b037df..1c22ff6d02 100644
--- a/collects/honu/core/private/operator.rkt
+++ b/collects/honu/core/private/operator.rkt
@@ -6,7 +6,8 @@
                      syntax/parse)
          (only-in "literals.rkt" %racket))
 
-(provide define-honu-operator/syntax)
+(provide (all-defined-out))
+
 (define-syntax (define-honu-operator/syntax stx)
   (syntax-parse stx
     [(_ name precedence associativity binary-function)
@@ -14,15 +15,12 @@
     [(_ name precedence associativity binary-function unary-function)
      #'(define-syntax name (make-honu-operator precedence associativity binary-function unary-function))]))
 
-(provide define-honu-fixture)
 (define-syntax (define-honu-fixture stx)
   (syntax-parse stx
     [(_ name transformer)
      #'(define-syntax name (make-fixture transformer))]))
 
 (define-syntax-rule (define-binary-operator name precedence associativity operator)
-  (begin
-    (provide name)
     (define-honu-operator/syntax name precedence associativity
                                  ;; binary
                                  (lambda (left right)
@@ -32,31 +30,44 @@
                                  ;; unary
                                  (lambda (argument)
                                    (with-syntax ([argument argument])
-                                     #'(%racket (operator argument)))))))
+                                     #'(%racket (operator argument))))))
 
 (define-syntax-rule (define-unary-operator name precedence associativity operator)
-                    (begin
-                      (provide name)
                       (define-honu-operator/syntax name precedence associativity
                                                    #f
                                                    ;; unary
                                                    (lambda (argument)
                                                      (with-syntax ([argument argument])
-                                                       #'(%racket (operator argument)))))))
+                                                       #'(%racket (operator argument))))))
 
-(provide honu-flow)
 (define-honu-operator/syntax honu-flow 0.001 'left
   (lambda (left right)
     (with-syntax ([left left]
                   [right right])
       #'(%racket (right left)))))
 
-(provide honu-equal)
+(begin-for-syntax
+  (define-syntax-rule (mutator change)
+                      (lambda (left right)
+                        (with-syntax ([left left]
+                                      [right (change left right)])
+                          #'(%racket (set! left right))))))
+
+;; Traditional assignment operator
 (define-honu-operator/syntax honu-equal 0.0001 'left
-  (lambda (left right)
-    (with-syntax ([left left]
-                  [right right])
-      #'(%racket (set! left right)))))
+  (mutator (lambda (left right) right)))
+
+(define-syntax-rule (define-honu-operator-= name operation)
+  (define-honu-operator/syntax name 0.0001 'left
+                               (mutator (lambda (left right)
+                                          (with-syntax ([left left] [right right])
+                                            #'(operation left right))))))
+
+;; Operators that mutate the left hand side
+(define-honu-operator-= honu-+= +)
+(define-honu-operator-= honu--= -)
+(define-honu-operator-= honu-*= *)
+(define-honu-operator-= honu-/= /)
 
 (define-binary-operator honu-+ 1 'left +)
 (define-binary-operator honu-- 1 'left -)
diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt
index 03e326ed64..3ed661a4d0 100644
--- a/collects/honu/core/private/parse2.rkt
+++ b/collects/honu/core/private/parse2.rkt
@@ -325,7 +325,10 @@
                                             (if unary-transformer
                                               (unary-transformer stuff)
                                               (error 'unary "cannot be used as a unary operator in ~a" #'head))))
-                                        (emit-local-step stuff output #:id #'binary-transformer)
+                                        #;
+                                        (debug "Binary transformer ~a\n" binary-transformer)
+                                        #;
+                                        (emit-local-step stuff output #:id binary-transformer)
                                         (with-syntax ([out (parse-all output)])
                                           #'(%racket out)))
 
diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt
index d4eb2c7928..1377f067ed 100644
--- a/collects/honu/core/read.rkt
+++ b/collects/honu/core/read.rkt
@@ -36,7 +36,8 @@
 (define-lex-abbrev string-character (:or (:: #\\ any-char)
                                          (:~ #\")))
 (define-lex-abbrev string (:: #\" (:* string-character) #\"))
-(define-lex-abbrev operator (:or "+" "!=" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
+(define-lex-abbrev operator (:or "+=" "-=" "*=" "/="
+                                 "+" "!=" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
                                  ">=" "<-" "<" ">" "!" "::" ":=" "%"))
 (define-lex-abbrev block-comment (:: "/*"
                                      (complement (:: any-string "*/" any-string))