[honu] handle unary operators. add some common functions and binary operators

collects/honu/core/main.rkt

@@ -17,12 +17,16 @@
                      [honu-+ +] [honu-- -]
                      [honu-* *] [honu-/ /]
                      [honu-^ ^]
+                     [honu-> >] [honu-< <]
+                     [honu->= >=] [honu-<= <=]
                      [honu-flow \|]
                      [honu-dot |.|]
                      [honu-cons ::]
                      [honu-and and] [honu-and &&]
                      [honu-or or] [honu-or \|\|]
+                     [honu-not not] [honu-not !]
                      [honu-structure structure]
+                     [honu-structure struct]
                      [literal:honu-= =]
                      [literal:semicolon |;|]
                      [literal:honu-comma |,|]

collects/honu/core/private/honu2.rkt

@@ -83,10 +83,25 @@
                     (begin
                       (provide name)
                       (define-honu-operator/syntax name precedence associativity
+                                                   ;; binary
                                                    (lambda (left right)
                                                      (with-syntax ([left left]
                                                                    [right right])
-                                                       #'(operator left right))))))
+                                                       #'(operator left right)))
+                                                   ;; unary
+                                                   (lambda (argument)
+                                                     (with-syntax ([argument argument])
+                                                       #'(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])
+                                                       #'(operator argument))))))
 
 (provide honu-dot)
 (define-honu-operator/syntax honu-dot 10000 'left
@@ -112,6 +127,12 @@
 (define-binary-operator honu-* 2 'left *)
 (define-binary-operator honu-/ 2 'left /)
 (define-binary-operator honu-^ 2 'right expt)
+(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-unary-operator honu-not 0.7 'left not)

collects/honu/core/private/operator.rkt

@@ -7,5 +7,7 @@
 (provide define-honu-operator/syntax)
 (define-syntax (define-honu-operator/syntax stx)
   (syntax-parse stx
-    [(_ name precedence associativity function)
+    [(_ name precedence associativity binary-function)
-     #'(define-syntax name (make-honu-operator precedence associativity function))]))
+     #'(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))]))

collects/honu/core/private/parse2.rkt

@@ -175,7 +175,8 @@
          [(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))
-          (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
+          (define binary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
+          (define unary-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 3))
           (define higher
             (case association
               [(left) >]
@@ -184,7 +185,13 @@
           (if (higher new-precedence precedence)
             (do-parse #'(rest ...) new-precedence
                       (lambda (stuff)
-                        (left (operator-transformer current stuff)))
+                        (if current
+                          (if binary-transformer
+                            (left (binary-transformer current stuff))
+                            (error '#'head "cannot be used as a binary operator"))
+                          (if unary-transformer
+                            (left (unary-transformer stuff))
+                            (error '#'head "cannot be used as a unary operator"))))
                       #f)
             (do-parse #'(head rest ...)
                       0
@@ -250,10 +257,10 @@
                       (if current
                         (let ()
                           (debug "function call ~a\n" left)
-                          (define call (left (with-syntax ([current current]
+                          (define call (with-syntax ([current current]
-                                                      [(parsed-args ...)
+                                                           [(parsed-args ...)
-                                                       (parse-comma-expression #'(args ...)) ])
+                                                            (parse-comma-expression #'(args ...)) ])
-                                          #'(current parsed-args ...))))
+                                          #'(current parsed-args ...)))
                           (do-parse #'(rest ...) precedence left call))
                         (let ()
                           (debug "inner expression ~a\n" #'(args ...))

collects/honu/core/private/transformer.rkt

@@ -33,16 +33,22 @@
 #;
 (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 3 0 #f 
+               (make-struct-type 'honu-operator #f 4 0 #f 
                                  (list (list prop:honu-operator #t))
                                  (current-inspector) 0))
 
-(define (make-honu-operator precedence associativity proc)
+(define (make-honu-operator precedence associativity binary unary)
-  (unless (and (procedure? proc)
+  (when (and (procedure? binary)
-               (procedure-arity-includes? proc 2))
+             (not (procedure-arity-includes? binary 2)))
     (raise-type-error
       'define-honu-operator/syntax
       "procedure (arity 2)"
-      proc))
+      binary))
-  (-make-honu-operator precedence associativity proc))
+  (when (and (procedure? unary)
+             (not (procedure-arity-includes? unary 1)))
+    (raise-type-error
+      'define-honu-operator/syntax
+      "procedure (arity 1)"
+      unary))
+  (-make-honu-operator precedence associativity binary unary))
 

collects/honu/core/read.rkt

@@ -24,16 +24,17 @@
 (define-lex-abbrev digit (:/ #\0 #\9))
 (define-lex-abbrev identifier-first-character (:or (:/ #\a #\z)
                                                    (:/ #\A #\Z)
-                                                   ":"))
+                                                   ":" "_"))
 (define-lex-abbrev identifier-character (:or identifier-first-character
                                              digit))
 (define-lex-abbrev identifier (:: identifier-first-character
                                   (:* identifier-character)))
-(define-lex-abbrev number (:+ digit))
+(define-lex-abbrev number (:: (:+ digit) (:? (:: "." (:+ digit)))))
 (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))
                                      "*/"))

collects/honu/main.rkt

@@ -11,7 +11,10 @@
     ...))
 
 (provide-module "core/main.rkt"
+                "private/common.rkt"
                 ;;"private/struct.honu"
                 ;;"private/function.honu"
                 ;;"private/common.honu"
                 )
+
+(provide sqr sqrt sin max)

collects/honu/private/common.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+
+(provide sqr)
+(define (sqr x) (* x x))