[honu] redo operator parsing to fix various precedence cases. add a new quasi-operator macro that can consume as much input on the right as it wants and use that to call methods on objects. change = to equal?. allow variables to be defined in classes

collects/honu/core/main.rkt

@@ -5,13 +5,15 @@
          "private/macro2.rkt"
          (for-syntax (only-in "private/macro2.rkt" honu-syntax))
          "private/class.rkt"
-         (for-syntax (only-in "private/parse2.rkt" honu-expression))
+         (for-syntax (prefix-in class: syntax/parse))
+         (for-syntax (only-in "private/parse2.rkt" honu-expression honu-identifier))
          (prefix-in literal: "private/literals.rkt"))
 
 (provide #%top
          #%datum
          print printf true false
          (for-syntax (rename-out [honu-expression expression]
+                                 [honu-identifier identifier]
                                  [honu-syntax syntax]))
          (rename-out [#%dynamic-honu-module-begin #%module-begin]
                      [honu-top-interaction #%top-interaction]
@@ -22,6 +24,9 @@
                      [honu-require require]
                      [honu-macro macro]
                      [honu-syntax syntax]
+                     [honu-while while]
+                     [honu-match match]
+                     [honu-with with]
                      [honu-var var]
                      [honu-val val]
                      [honu-for for]
@@ -30,15 +35,18 @@
                      [honu-quasiquote quasiquote]
                      [honu-+ +] [honu-- -]
                      [honu-* *] [honu-/ /]
+                     [honu-modulo %]
                      [honu-^ ^]
                      [honu-> >] [honu-< <]
                      [honu->= >=] [honu-<= <=]
-                     [honu-= =]
+                     ; [honu-= =]
+                     [honu-equal =]
                      [honu-assignment :=]
                      [literal:honu-<- <-]
                      [honu-map map]
                      [honu-flow \|]
                      [honu-dot %dot]
+                     [honu--> %arrow]
                      [honu-string=? string_equal]
                      [honu-cons ::]
                      [honu-and and] [honu-and &&]

collects/honu/core/private/class.rkt

@@ -2,6 +2,7 @@
 
 (require "macro2.rkt"
          "literals.rkt"
+         (only-in "honu2.rkt" honu-var honu-equal)
          (for-syntax racket/base
                      "literals.rkt"
                      "parse2.rkt"
@@ -13,15 +14,18 @@
     (syntax-parse method #:literals (define)
       [(define (name args ...) body ...)
        #'(define/public (name args ...) body ...)]))
-  (define-splicing-syntax-class honu-class-method
+  (define-splicing-syntax-class honu-class-thing
+                                #:literals (honu-equal honu-var)
     [pattern method:honu-function
-             #:with result (replace-with-public #'method.result)]))
+             #:with result (replace-with-public #'method.result)]
+    [pattern (~seq honu-var name:identifier honu-= out:honu-expression)
+             #:with result #'(field [name out.result])]))
 
 (provide honu-class)
 (define-honu-syntax honu-class
   (lambda (code context)
     (syntax-parse code #:literal-sets (cruft)
-      [(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest)
+      [(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-thing ...) . rest)
        (define class
          #'(%racket (define name (class* object% ()
                                          (super-new)
@@ -33,7 +37,7 @@
 (define-honu-syntax honu-new
   (lambda (code context)
     (syntax-parse code #:literal-sets (cruft)
-      [(_ name (#%parens arg:honu-expression ...) . rest)
+      [(_ name (#%parens arg:honu-expression/comma) . rest)
        (define new #'(%racket (make-object name arg.result ...)))
        (values
          new

collects/honu/core/private/debug.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
-(require (for-syntax racket/base))
+(require (for-syntax racket/base
+                     syntax/parse))
 
 (provide debug)
 
@@ -34,8 +35,8 @@
 (define-for-syntax verbose? (getenv "HONU_DEBUG"))
 (define-syntax (debug stx)
   (if verbose?
-    (syntax-case stx ()
+    (syntax-parse stx
-      [(_ str x ...)
+      [(_ str:str x ...)
        (with-syntax ([file (filename (syntax-source #'str))]
                      [line (syntax-line #'str)]
                      [column (syntax-column #'str)])
@@ -43,6 +44,11 @@
                    (colorize file 'green)
                    (colorize line 'red)
                    (colorize column 'red)
-                   x ...))])
+                   x ...))]
+      [(_ level:number message:str x ...)
+       (if (>= (string->number verbose?)
+               (syntax->datum #'level))
+         #'(debug message x ...)
+         #'(void))])
     #'(void)))
 

collects/honu/core/private/fixture.rkt

@@ -0,0 +1,26 @@
+#lang racket/base
+
+(require (for-syntax racket/base))
+
+(provide (rename-out [prop:fixture? fixture?])
+         make-fixture
+         (rename-out [-fixture-ref fixture-ref]))
+(define-values (prop:fixture prop:fixture? prop:fixture-ref)
+               (make-struct-type-property 'fixture))
+
+#;
+(provide honu-operator?)
+(define-values (struct:fixture -make-fixture fixture? -fixture-ref fixture-set!)
+               (make-struct-type 'fixture #f 1 0 #f 
+                                 (list (list prop:fixture #t))
+                                 (current-inspector) 0))
+
+(define (make-fixture transformer)
+  (when (and (procedure? transformer)
+             (not (procedure-arity-includes? transformer 2)))
+    (raise-type-error
+      'define-fixture
+      "procedure (arity 2)"
+      transformer))
+  (-make-fixture transformer))
+

collects/honu/core/private/honu-typed-scheme.rkt

@@ -16,7 +16,7 @@
                      "util.rkt"
                      "ops.rkt"
                      "syntax.rkt"
-                     "parse.rkt"
+                     ;; "parse.rkt"
                      "parse2.rkt"
                      "literals.rkt"
                      )
@@ -35,6 +35,7 @@
 
 (begin-for-syntax
 
+#;
 (define parse-expr
   ;; The given syntax sequence must not be empty
   (let ()
@@ -209,6 +210,7 @@
 
     parse-expr))
 
+#;
 (define (parse-tail-expr expr-stxs)
   (syntax-parse expr-stxs
     #:literals (honu-return)
@@ -218,6 +220,7 @@
     [else (parse-expr expr-stxs)]))
 
 
+#;
 (define (parse-block-one context body combine-k done-k)
   (define (parse-one expr-stxs after-expr terminator)
     (define (checks)
@@ -254,6 +257,7 @@
                                                  ))
                        parse-one )]))
 
+#;
 (define (parse-block stx ctx)
   (let loop ([stx stx])
     (parse-block-one ctx
@@ -387,6 +391,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
 (define (display2 x y)
   (debug "~a ~a" x y))
 
+#;
 (define-syntax (honu-unparsed-expr stx)
   (syntax-parse stx
     [(_ expr ...)
@@ -474,7 +479,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
      ;; in the input such as parsing just ";".
      (with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))]
                    [(unparsed ...) unparsed])
-       (debug "Final parsed syntax ~a\n" (syntax->datum #'parsed))
+       (debug "Final parsed syntax\n~a\n" (pretty-format (syntax->datum #'parsed)))
        (if (null? (syntax->datum #'(unparsed ...)))
          #'parsed
          #'(begin parsed (honu-unparsed-begin unparsed ...))))]))

collects/honu/core/private/honu2.rkt

@@ -4,6 +4,7 @@
          "operator.rkt"
          "struct.rkt"
          "honu-typed-scheme.rkt"
+         racket/match
          racket/class
          racket/require
          (only-in "literals.rkt"
@@ -11,8 +12,10 @@
                   honu-in
                   honu-prefix
                   semicolon
+                  define-literal
                   %racket)
          (for-syntax syntax/parse
+                     racket/syntax
                      "debug.rkt"
                      "literals.rkt"
                      "parse2.rkt"
@@ -39,8 +42,8 @@
 (define-honu-syntax honu-var
   (lambda (code context)
     (syntax-parse code #:literal-sets (cruft)
-                       #:literals (honu-=)
+                       #:literals (honu-equal)
-      [(_ name:id honu-= one:honu-expression . rest)
+      [(_ name:id honu-equal one:honu-expression . rest)
        (values #'(%racket (define name one.result))
                #'rest
                #t)])))
@@ -49,8 +52,8 @@
 (define-honu-syntax honu-for
   (lambda (code context)
     (syntax-parse code #:literal-sets (cruft)
-                       #:literals (honu-= honu-in)
+                       #:literals (honu-equal honu-in)
-      [(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
+      [(_ iterator:id honu-equal start:honu-expression honu-to end:honu-expression
           honu-do body:honu-expression . rest)
        (values
            #'(%racket (for ([iterator (in-range start.result
@@ -136,8 +139,7 @@
             (cond
               [(honu-struct? left*) (let ([use (honu-struct-get left*)])
                                       (use left* 'right))]
-              [(object? left*) (lambda args
+              [(object? left*) (get-field right left*)]
-                                 (send/apply left* right args))]
               ;; possibly handle other types of data
               [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))))
 
@@ -164,15 +166,18 @@
 (define-binary-operator honu-<= 0.9 'left <=)
 (define-binary-operator honu-> 0.9 'left >)
 (define-binary-operator honu->= 0.9 'left >=)
-(define-binary-operator honu-= 0.9 'left =)
+;; (define-binary-operator honu-= 0.9 'left =)
 (define-binary-operator honu-and 0.5 'left and)
 (define-binary-operator honu-or 0.5 'left or)
 (define-binary-operator honu-cons 0.1 'right cons)
 (define-binary-operator honu-map 0.09 'left map)
 (define-binary-operator honu-string=? 1 'left string=?)
+(define-binary-operator honu-modulo 2 'left modulo)
 
 (define-unary-operator honu-not 0.7 'left not)
 
+(define-binary-operator honu-equal 1 'left equal?)
+
 (provide honu-top-interaction)
 (define-syntax (honu-top-interaction stx)
   (syntax-case stx ()
@@ -180,13 +185,17 @@
      #'(#%top-interaction . (honu-unparsed-begin rest ...))]))
 
 (begin-for-syntax
+  (define (fix-module-name name)
+    (format-id name "~a" (regexp-replace* #rx"_" (symbol->string (syntax->datum name)) "-")))
   (define-splicing-syntax-class require-form
                                 #:literals (honu-prefix)
                                 #:literal-sets (cruft)
     [pattern (~seq honu-prefix prefix module)
-             #:with result #'(prefix-in prefix module)]
+             #:with result (with-syntax ([module (fix-module-name #'module)])
+                             #'(prefix-in prefix module))]
     [pattern x:str #:with result #'x]
-    [pattern x:id #:with result #'x
+    [pattern x:id
+             #:with result (with-syntax ([name (fix-module-name #'x)]) #'name)
              #:when (not ((literal-set->predicate cruft) #'x))]))
 
 (define-for-syntax (racket-names->honu name)
@@ -217,3 +226,44 @@
          with
          #'rest
          #f)])))
+
+(provide honu-while)
+(define-honu-syntax honu-while
+  (lambda (code context)
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ condition:honu-expression body:honu-body . rest)
+       (values
+         #'(%racket (let loop ()
+                      body.result
+                      (when condition.result (loop))))
+         #'rest
+         #t)])))
+
+(provide honu-with honu-match)
+(define-literal honu-with)
+(define-honu-syntax honu-match
+  (lambda (code context)
+    (define-splicing-syntax-class match-clause
+                                  #:literal-sets (cruft)
+      [pattern (~seq (#%parens pattern ...)
+                     body:honu-body)
+               #:with code #'body.result])
+
+    (syntax-parse code #:literal-sets (cruft)
+                       #:literals (honu-with)
+      [(_ thing:honu-expression honu-with clause:match-clause ... . rest)
+       (values
+         #'(%racket (match thing.result
+                      [(clause.pattern ...) clause.code]
+                      ...))
+         #'rest
+         #t)])))
+
+(provide honu-->)
+(define-honu-fixture honu-->
+  (lambda (left rest)
+    (syntax-parse rest #:literal-sets (cruft)
+      [(_ name:identifier (#%parens argument:honu-expression/comma) . more)
+       (with-syntax ([left left])
+         (values #'(send/apply left name (list argument.result ...))
+                 #'more))])))

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-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
                 honu-!= honu-==

collects/honu/core/private/operator.rkt

@@ -2,6 +2,7 @@
 
 (require (for-syntax racket/base
                      "transformer.rkt"
+                     "fixture.rkt"
                      syntax/parse))
 
 (provide define-honu-operator/syntax)
@@ -11,3 +12,9 @@
      #'(define-syntax name (make-honu-operator precedence associativity binary-function #f))]
     [(_ 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))]))

collects/honu/core/private/parse2.rkt

@@ -9,6 +9,7 @@
          "debug.rkt"
          "compile.rkt"
          (prefix-in transformer: "transformer.rkt")
+         (prefix-in fixture: "fixture.rkt")
          racket/pretty
          syntax/stx
          syntax/parse/experimental/splicing
@@ -49,12 +50,17 @@
 
 (define (bound-to-operator? check)
   (let ([value (get-value check)])
-    (debug "operator? ~a ~a\n" check value)
+    (debug 2 "operator? ~a ~a\n" check value)
     (transformer:honu-operator? value)))
 
+(define (bound-to-fixture? check)
+  (let ([value (get-value check)])
+    (debug 2 "fixture? ~a ~a\n" check value)
+    (fixture:fixture? value)))
+
 (define (bound-to-macro? check)
   (let ([value (get-value check)])
-    (debug "macro? ~a ~a\n" check value)
+    (debug 2 "macro? ~a ~a\n" check value)
     (transformer:honu-transformer? value))
   #;
   (let ([value (syntax-local-value check (lambda () #f))])
@@ -68,6 +74,10 @@
   (and (identifier? something)
        (bound-to-operator? something)))
 
+(define (honu-fixture? something)
+  (and (identifier? something)
+       (bound-to-fixture? something)))
+
 (define (semicolon? what)
   (define-literal-set check (semicolon))
   (define is (and (identifier? what)
@@ -79,7 +89,7 @@
   (define-literal-set check (honu-comma))
   (define is (and (identifier? what)
                     ((literal-set->predicate check) what)))
-  (debug "Comma? ~a ~a\n" what is)
+  (debug 2 "Comma? ~a ~a\n" what is)
   is)
 
 (define-literal-set argument-stuff [honu-comma])
@@ -137,7 +147,7 @@
   (define-literal-set check (honu-comma semicolon colon))
   (define is (and (identifier? what)
                   ((literal-set->predicate check) what)))
-  (debug "Comma? ~a ~a\n" what is)
+  (debug 2 "Comma? ~a ~a\n" what is)
   is)
 
 (provide honu-function)
@@ -254,6 +264,11 @@
           (do-macro #'head #'(rest ...) precedence left current stream)]
          [(parsed-syntax? #'head)
           (do-parse #'(rest ...) precedence left #'head)]
+         [(honu-fixture? #'head)
+          (debug 2 "Fixture ~a\n" #'head)
+          (define transformer (fixture:fixture-ref (syntax-local-value #'head) 0))
+          (define-values (output rest) (transformer current stream))
+          (do-parse rest precedence left output)]
          [(honu-operator? #'head)
           (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
           (define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
@@ -265,6 +280,20 @@
               [(right) >=]))
           (debug "precedence old ~a new ~a higher? ~a\n" precedence new-precedence (higher new-precedence precedence))
           (if (higher new-precedence precedence)
+            (let-values ([(parsed unparsed)
+                          (do-parse #'(rest ...) new-precedence
+                                    (lambda (stuff)
+                                      (if current
+                                        (if binary-transformer
+                                          (binary-transformer current stuff)
+                                          (error '#'head "cannot be used as a binary operator"))
+                                        (if unary-transformer
+                                          (unary-transformer stuff)
+                                          (error '#'head "cannot be used as a unary operator"))))
+                                    #f)])
+              (do-parse unparsed precedence left parsed))
+
+            #;
             (do-parse #'(rest ...) new-precedence
                       (lambda (stuff)
                         (if current
@@ -275,6 +304,8 @@
                             (left (unary-transformer stuff))
                             (error '#'head "cannot be used as a unary operator"))))
                       #f)
+            (values (left current) stream)
+            #;
             (do-parse #'(head rest ...)
                       0
                       (lambda (x) x)
@@ -284,6 +315,8 @@
           (values (left final)
                   stream)]
          [else
+           (define-splicing-syntax-class no-left
+             [pattern (~seq) #:when (not current)])
            (syntax-parse #'(head rest ...) #:literal-sets (cruft)
              [((semicolon more ...) . rest)
               #;
@@ -296,17 +329,8 @@
               (when (not (stx-null? unparsed))
                 (raise-syntax-error 'parse "found unparsed input" unparsed))
               (values (parse-all #'(more ...)) #'rest)]
-             [(function:honu-function . rest)
+             [(left:no-left function:honu-function . rest)
               (values #'function.result #'rest)]
-             #;
-             [(function:identifier (#%parens args ...) (#%braces code ...) . rest)
-              (values (with-syntax ([(parsed-arguments ...)
-                                     (parse-arguments #'(args ...))])
-                        #'(define (function parsed-arguments ...)
-                            (let-syntax ([parse-more (lambda (stx)
-                                                       (parse-all #'(code ...)))])
-                              (parse-more))))
-                      #'rest)]
              [else (syntax-parse #'head
                      #:literal-sets (cruft)
                      [(%racket x)
@@ -314,7 +338,7 @@
                         (values (left current) stream)
                         (do-parse #'(rest ...) precedence left #'head))]
                      [x:atom
-                       (debug "atom ~a current ~a\n" #'x current)
+                       (debug 2 "atom ~a current ~a\n" #'x current)
                        (if current
                          (values (left current) stream)
                          (do-parse #'(rest ...) precedence left #'x))]
@@ -354,13 +378,14 @@
                       (if current
                         (if (> precedence 9000)
                           (let ()
+                            (debug 2 "higher precedence call ~a\n" current)
                             (define call (with-syntax ([current (left current)]
                                                        [(parsed-args ...)
                                                         (parse-comma-expression #'(args ...)) ])
                                            #'(current parsed-args ...)))
                             (do-parse #'(rest ...) 9000 (lambda (x) x) call))
                           (let ()
-                            (debug "function call ~a\n" left)
+                            (debug 2 "function call ~a\n" left)
                             (define call (with-syntax ([current current]
                                                        [(parsed-args ...)
                                                         (parse-comma-expression #'(args ...)) ])
@@ -435,7 +460,23 @@
     (list (parsed-things stx unparsed) (with-syntax ([parsed parsed])
                                          #'(%racket parsed)))))
 
+(provide honu-identifier)
+(define-splicing-syntax-class honu-identifier
+  [pattern x:id #:with result #'x])
+
 (provide identifier-comma-list)
 (define-splicing-syntax-class identifier-comma-list
                               #:literal-sets (cruft)
   [pattern (~seq (~seq name:id (~optional honu-comma)) ...)]) 
+
+(provide honu-expression/comma)
+(define-splicing-syntax-class honu-expression/comma
+  [pattern (~seq x ...) #:with (result ...) (parse-comma-expression #'(x ...))])
+
+(provide honu-body)
+(define-splicing-syntax-class honu-body
+                              #:literal-sets (cruft)
+  [pattern (~seq (#%braces code ...))
+           #:with result #'(let-syntax ([parse-more (lambda (stx)
+                                                      (honu->racket (parse-all #'(code ...))))])
+                             (parse-more))])

collects/honu/core/read.rkt

@@ -36,8 +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))
                                      "*/"))
@@ -73,6 +73,7 @@
     [":" (token-identifier '%colon)]
     ["'" (token-identifier 'quote)]
     ["`" (token-identifier 'quasiquote)]
+    ["->" (token-identifier '%arrow)]
     [operator (token-identifier (string->symbol lexeme))]
     [";" (token-semicolon)]
     ;; strip the quotes from the resulting string

collects/honu/main.rkt

@@ -25,6 +25,7 @@
          substring
          (rename-out [honu-cond cond]
                      [null empty]
+                     [current-inexact-milliseconds currentMilliseconds]
                      [string-length string_length]
                      [racket:empty? empty?]
                      [racket:first first]

collects/tests/honu/class.honu

@@ -1,6 +1,7 @@
 #lang honu
 
 class What(x){
+  var q = 2
   foobar(z){
     z + x
   }