added desugaring for binary operators, without well formedness checking, made the tokenizer handle parens adjacent to operators and other parens correctly (by caching tokens, instead of modifying the input port)

Author: Daniel Patterson

src/lang/ast.rkt

@@ -75,6 +75,9 @@ these metadata purposes.
 ;; s-op: srcloc op Expr Expr -> s-op
 (struct s-op (syntax op left right) #:transparent)
 
+;; s-paren: srcloc Expr -> s-paren
+(struct s-paren (syntax expr) #:transparent)
+
 ;; An Expr is a
 ;; (U s-obj s-onion s-list s-app s-left-app s-id
 ;;    s-assign s-num s-bool s-str

src/lang/desugar.rkt

@@ -127,6 +127,21 @@
            (s-bind s1 id (a-any)) bind)]
       [_ bind])))
 
+(define op-method-table
+  (make-immutable-hash
+   `((,op+ . "plus")
+     (,op- . "minus")
+     (,op* . "times")
+     (,op/ . "divide")
+     (,op<= . "lessequal")
+     (,op< . "lessthan")
+     (,op>= . "greaterequal")
+     (,op> . "greaterthan")
+     (,op== . "equals")
+     ;; NOTE(dbp): we deal with not specially, since it is .equals(...).not() 
+     ;(,op<> . "")
+     )))
+
 (define (desugar-internal ast)
   (define ds desugar-internal)
   (define (ds-args binds)
@@ -219,7 +234,7 @@
     [(s-try s try exn catch)
      ;; NOTE(joe & dbp): The identifier in the exn binding of the try is carefully
      ;; shadowed here to avoid capturing any names in Pyret.  It is both
-     ;; the name that the compiler will use for the exception, and the name
+     ;; the name that the compiler will use for the exc, and the name
      ;; that desugaring uses to provide the wrapped exception from the error
      ;; library.
      (define make-error (s-app s (s-bracket s (s-id s 'error)
@@ -256,6 +271,20 @@
 
     [(s-bracket-method s obj field) (s-bracket-method s (ds obj) (ds field))]
 
+    [(s-paren _ e) (ds e)]
+
+    ;; NOTE(dbp): notequals is special because it requires two method
+    [(s-op s 'op<> e1 e2)
+     (s-app s (s-bracket s
+               (s-app s (s-bracket s (ds e1) (s-str s "equals"))
+                      (list (ds e2)))
+               (s-str s "not"))
+            (list))]
+
+    [(s-op s op e1 e2)
+     (s-app s (s-bracket s (ds e1) (s-str s (hash-ref op-method-table op)))
+                      (list (ds e2)))]
+
     [(or (s-num _ _)
          (s-bool _ _)
          (s-str _ _)

src/lang/parser.rkt

@@ -156,13 +156,14 @@
   (syntax-parse stx
     #:datum-literals (binop-expr expr paren-expr)
     [(binop-expr _ _ _) (parse-stmt stx)]
-    [(paren-expr "(" e ")") (parse-binop-expr #'e)]
+    [(paren-expr "(" e ")") (s-paren (loc stx) (parse-binop-expr #'e))]
     [(expr e) (parse-expr #'e)]
     [(binop-expr e) (parse-binop-expr #'e)]))
 
 (define (parse-op stx)
   (syntax-parse stx
-    [(op str) (hash-ref op-lookup-table (syntax->datum #'str))]))
+    #:datum-literals (binop)
+    [(binop str) (hash-ref op-lookup-table (syntax->datum #'str))]))
 
 (define (parse-return-ann stx)
   (syntax-parse stx

src/lang/runtime.rkt

@@ -583,6 +583,7 @@ And the object was:
     (set! meta-str-store
       (make-immutable-hash
         `(("append" . ,(mk-prim-fun string-append 'append mk-str p-str-s (s1 s2) (p-str? p-str?)))
+          ("plus" . ,(mk-prim-fun string-append 'plus mk-str p-str-s (s1 s2) (p-str? p-str?)))
           ("contains" . ,(mk-prim-fun string-contains 'contains mk-bool p-str-s (s1 s2) (p-str? p-str?)))
           ("length" . ,(mk-prim-fun string-length 'length mk-num p-str-s (s) (p-str?)))
           ("tonumber" . ,(mk-prim-fun string->number 'tonumber mk-num p-str-s (s) (p-str?)))

src/lang/tokenizer.rkt

@@ -4,6 +4,7 @@
          ragg/support
          racket/set
          racket/port
+         racket/list
          "grammar.rkt")
 (provide tokenize)
 
@@ -27,12 +28,14 @@
   operator-chars
   (union "+" "-" "*" "/" "<=" ">=" "==" "<>" "<" ">"))
 
-
+(define (get-middle-pos n pos)
+  (position (+ n (position-offset pos))
+            (position-line pos)
+            (+ n (position-col pos))))
+  
 (define (tokenize ip)
   (port-count-lines! ip)
-  (define (push-back-paren)
-    (set! ip (input-port-append  #t (open-input-string " (")
-                                 ip)))
+  (define extra-token #f)
   (define my-lexer
     (lexer-src-pos
      ;; open parenthesis: preceded by space and not
@@ -41,14 +44,18 @@
      ;; doing this at the tokenizer level, we don't need to deal
      ;; with whitespace in the grammar.
      ["(("
-      (begin
-        (push-back-paren)
-        (token PARENNOSPACE "("))]
+      (let [(middle-pos (get-middle-pos 1 start-pos))]
+      (return-without-pos
+       (list (position-token (token PARENNOSPACE "(") start-pos middle-pos)
+             (position-token (token PARENSPACE "(") middle-pos end-pos))))]
      [(concatenation operator-chars "(")
-      (let [(op (substring lexeme 0
-                           (- (string-length lexeme) 1)))]
-        (push-back-paren)
-        (token op op))]
+      (let* [(op (substring lexeme 0
+                           (- (string-length lexeme) 1)))
+            (op-len (string-length op))
+            (middle-pos (get-middle-pos op-len start-pos))]
+        (return-without-pos
+         (list (position-token (token op op) start-pos middle-pos)
+               (position-token (token PARENSPACE "(") middle-pos end-pos))))]
      [(concatenation whitespace "(")
       (token PARENSPACE "(")]
      ["("
@@ -112,5 +119,14 @@
      [(eof)
       (void)]
      ))
-    (define (next-token) (my-lexer ip))
+    (define (next-token)
+      (if extra-token
+          (let [(rv extra-token)]
+            (set! extra-token #f)
+            rv)
+          (let [(tokens (my-lexer ip))]
+            (cond
+             [(list? tokens) (set! extra-token (second tokens))
+                             (first tokens)]
+             [else tokens]))))
     next-token)

src/tests/compile-tests.rkt

@@ -656,6 +656,34 @@
 
 ))
 
+(define binary-operators (test-suite "binary-operators"
+  (check-pyret "6 - 4 - 1" (p:mk-num 1))
+  (check-pyret "6 - (4 - 1)" (p:mk-num 3))
+  (check-pyret "5 + 5" (p:mk-num 10))
+  (check-pyret "5 * 5" (p:mk-num 25))
+  (check-pyret "5 / 5" (p:mk-num 1))
+  (check-pyret "4 <= 5" (p:mk-bool #t))
+  (check-pyret "4 < 5" (p:mk-bool #t))
+  (check-pyret "4 >= 5" (p:mk-bool #f))
+  (check-pyret "4 > 5" (p:mk-bool #f))
+  (check-pyret "4 <> 5" (p:mk-bool #t))
+  (check-pyret "4 == 6" (p:mk-bool #f))
+  (check-pyret "fun f(y):
+                  y
+                end
+                f(1+2)" (p:mk-num 3))
+  (check-pyret "fun f(y):
+                  y
+                end
+                f((1+2))" (p:mk-num 3))
+  (check-pyret "'hello' + ' world'" (p:mk-str "hello world"))
+  (check-pyret-exn "5 + 'foo'" "Bad args to prim")
+  (check-pyret "x = {lessequal(s,o): 3 end} x <= 5" (p:mk-num 3))
+  (check-pyret-exn "x = {lessthan: \\s,o: 3 end} x < 5" "Arity")
+  (check-pyret-exn "x = {greaterthan: 3} x > 5" "expected function")
+  (check-pyret-exn "x = {} x <= 5" "lessequal was not found")
+))
+                               
 (define all (test-suite "all"
   constants
   functions
@@ -668,7 +696,8 @@
   for-block
   methods
   exceptions
-  ids-and-vars))
+  ids-and-vars
+  binary-operators))
 
 (run-tests all 'normal)
 

src/tests/parse-tests.rkt

@@ -519,17 +519,19 @@
                                                       (list (s-num _ 3))))
                                          (s-num _ 4)))
    (check/block "(1 - 2) + 3" (s-op _ op+
-                                    (s-op _ op-
+                                    (s-paren _
+                                        (s-op _ op-
                                           (s-num _ 1)
-                                          (s-num _ 2))
+                                          (s-num _ 2)))
                                     (s-num _ 3)))
    (check/block "(3 * (1 - 2)) / 3"
                 (s-op _ op/
-                      (s-op _ op*
+                      (s-paren _ (s-op _ op*
                             (s-num _ 3)
-                            (s-op _ op-
+                            (s-paren _
+                                (s-op _ op-
                                   (s-num _ 1)
-                                  (s-num _ 2)))
+                                  (s-num _ 2)))))
                       (s-num _ 3)))
    (check/block "x = 3 + 4"
                 (s-let _ (s-bind _ 'x _) (s-op _ op+ (s-num _ 3) (s-num _ 4))))
@@ -543,34 +545,39 @@
    (check/block "1+(2*3)"
                 (s-op _ op+
                       (s-num _ 1)
-                      (s-op _ op* (s-num _ 2) (s-num _ 3))))
+                      (s-paren _ (s-op _ op* (s-num _ 2) (s-num _ 3)))))
 
    (check/block "1*(2-3)"
                 (s-op _ op*
                       (s-num _ 1)
-                      (s-op _ op- (s-num _ 2) (s-num _ 3))))
+                      (s-paren _ (s-op _ op- (s-num _ 2) (s-num _ 3)))))
 
    (check/block "1/(2*3)"
                 (s-op _ op/
                       (s-num _ 1)
-                      (s-op _ op* (s-num _ 2) (s-num _ 3))))
+                      (s-paren _ (s-op _ op* (s-num _ 2) (s-num _ 3)))))
 
    (check/block "1-(2*3)"
                 (s-op _ op-
                       (s-num _ 1)
-                      (s-op _ op* (s-num _ 2) (s-num _ 3))))
+                      (s-paren _ (s-op _ op* (s-num _ 2) (s-num _ 3)))))
 
    (check/block "foo((2+3))"
                 (s-app _
                        (s-id _ 'foo)
                        (list
-                        (s-op _ op* (s-num _ 2) (s-num _ 3)))))
+                        (s-paren _ (s-op _ op* (s-num _ 2) (s-num _ 3))))))
+
+   (check/block "fun f(y):
+                  y
+                end
+                f((1+2))" _ _)
 
    (check/block "foo((2+3)*2)"
                 (s-app _
                        (s-id _ 'foo)
                        (list
-                        (s-op _ op* (s-op _ op+ (s-num _ 2) (s-num _ 3))
+                        (s-op _ op* (s-paren _ (s-op _ op+ (s-num _ 2) (s-num _ 3)))
                               (s-num _ 2)))))
 
    (check/block "1 < 2"
@@ -593,7 +600,7 @@
 
    (check/block "1 <= (1+2)"
                 (s-op _ op<= (s-num _ 1)
-                      (s-op _ op+ (s-num _ 1) (s-num _ 2))))
+                      (s-paren _ (s-op _ op+ (s-num _ 1) (s-num _ 2)))))
 
    (check-parse/fail "when(1 < 2): 3" "parsing error")
    ))