[honu] set associativty for operators

collects/honu/core/private/honu2.rkt

@@ -73,22 +73,24 @@
   (lambda (code context)
     (syntax-parse code
       [(_ expression rest ...)
-       (values #'(quasiquote expression) #'(rest ...) #f)])))
+       (values #'(quasiquote expression)
+               #'(rest ...)
+               #f)])))
 
-(define-syntax-rule (define-binary-operator name precedence operator)
+(define-syntax-rule (define-binary-operator name precedence associativity operator)
                     (begin
                       (provide name)
-                      (define-honu-operator/syntax name precedence
+                      (define-honu-operator/syntax name precedence associativity
                                                    (lambda (left right)
                                                      (with-syntax ([left left]
                                                                    [right right])
                                                        #'(operator left right))))))
 
-(define-binary-operator honu-+ 1 +)
+(define-binary-operator honu-+ 1 'left +)
-(define-binary-operator honu-- 1 -)
+(define-binary-operator honu-- 1 'left -)
-(define-binary-operator honu-* 2 *)
+(define-binary-operator honu-* 2 'left *)
-(define-binary-operator honu-/ 2 /)
+(define-binary-operator honu-/ 2 'left /)
-(define-binary-operator honu-^ 2 expt)
+(define-binary-operator honu-^ 2 'right expt)
-(define-binary-operator honu-and 0.5 and)
+(define-binary-operator honu-and 0.5 'left and)
-(define-binary-operator honu-or 0.5 or)
+(define-binary-operator honu-or 0.5 'left or)
-(define-binary-operator honu-cons 0.1 cons)
+(define-binary-operator honu-cons 0.1 'right cons)

collects/honu/core/private/operator.rkt

@@ -7,5 +7,5 @@
 (provide define-honu-operator/syntax)
 (define-syntax (define-honu-operator/syntax stx)
   (syntax-parse stx
-    [(_ name precedence function)
+    [(_ name precedence associativity function)
-     #'(define-syntax name (make-honu-operator precedence function))]))
+     #'(define-syntax name (make-honu-operator precedence associativity function))]))

collects/honu/core/private/parse2.rkt

@@ -173,8 +173,8 @@
                                        (more-parsing . rest)))))]
          [(honu-operator? #'head)
           (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
-          (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 1))
+          (define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
-          (define association 'left)
+          (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
           (define higher
             (case association
               [(left) >]

collects/honu/core/private/transformer.rkt

@@ -33,16 +33,16 @@
 #;
 (provide honu-operator?)
 (define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!)
-               (make-struct-type 'honu-operator #f 2 0 #f 
+               (make-struct-type 'honu-operator #f 3 0 #f 
                                  (list (list prop:honu-operator #t))
                                  (current-inspector) 0))
 
-(define (make-honu-operator precedence proc)
+(define (make-honu-operator precedence associativity proc)
   (unless (and (procedure? proc)
                (procedure-arity-includes? proc 2))
     (raise-type-error
       'define-honu-operator/syntax
       "procedure (arity 2)"
       proc))
-  (-make-honu-operator precedence proc))
+  (-make-honu-operator precedence associativity proc))
 

collects/honu/core/read.rkt

@@ -33,6 +33,7 @@
 (define-lex-abbrev string-character (:or (:: #\\ any-char)
                                          (:~ #\")))
 (define-lex-abbrev string (:: #\" (:* string-character) #\"))
+(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^"))
 (define-lex-abbrev block-comment (:: "/*"
                                      (complement (:: any-string "*/" any-string))
                                      "*/"))
@@ -68,10 +69,11 @@
     ["!" (token-identifier '!)]
     ["'" (token-identifier 'quote)]
     ["`" (token-identifier 'quasiquote)]
-    ["=" (token-identifier '=)]
+    ;; ["=" (token-identifier '=)]
-    ["*" (token-identifier '*)]
+    [operator (token-identifier (string->symbol lexeme))]
-    ["/" (token-identifier '/)]
+    ;; ["*" (token-identifier '*)]
-    ["+" (token-identifier '+)]
+    ;; ["/" (token-identifier '/)]
+    ;; ["+" (token-identifier '+)]
     [";" (token-identifier '|;|)]
     ;; strip the quotes from the resulting string
     ;; TODO: find a more optimal way
@@ -342,7 +344,7 @@
   (define (do-parse current tokens table)
     (define (fail tokens)
       (if (null? tokens)
-        (error 'parse "error while parsing")
+        (error 'read "error while reading")
         (let ([first (car tokens)])
           ;; hack to get the current failure behavior
           (do-parse current '() table)