From 85110e177bc8dc5db35912338b729ad6eee3577d Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 15 Aug 2011 16:36:52 -0600 Subject: [PATCH] [honu] handle unary operators. add some common functions and binary operators --- collects/honu/core/main.rkt | 4 ++++ collects/honu/core/private/honu2.rkt | 23 +++++++++++++++++++++- collects/honu/core/private/operator.rkt | 6 ++++-- collects/honu/core/private/parse2.rkt | 19 ++++++++++++------ collects/honu/core/private/transformer.rkt | 18 +++++++++++------ collects/honu/core/read.rkt | 7 ++++--- collects/honu/main.rkt | 3 +++ collects/honu/private/common.rkt | 4 ++++ 8 files changed, 66 insertions(+), 18 deletions(-) create mode 100644 collects/honu/private/common.rkt diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index abc569e69f..06d14c6bff 100644 --- a/collects/honu/core/main.rkt +++ b/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 |,|] diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 7f74e6e9ba..dcf94c5ef6 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/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) diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt index c9b6226c2f..eacdb52132 100644 --- a/collects/honu/core/private/operator.rkt +++ b/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) - #'(define-syntax name (make-honu-operator precedence associativity function))])) + [(_ name precedence associativity binary-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))])) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index d6558e787b..83b0c883c8 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/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] - [(parsed-args ...) - (parse-comma-expression #'(args ...)) ]) - #'(current parsed-args ...)))) + (define call (with-syntax ([current current] + [(parsed-args ...) + (parse-comma-expression #'(args ...)) ]) + #'(current parsed-args ...))) (do-parse #'(rest ...) precedence left call)) (let () (debug "inner expression ~a\n" #'(args ...)) diff --git a/collects/honu/core/private/transformer.rkt b/collects/honu/core/private/transformer.rkt index 24ea25d069..6500e0d79e 100644 --- a/collects/honu/core/private/transformer.rkt +++ b/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) - (unless (and (procedure? proc) - (procedure-arity-includes? proc 2)) +(define (make-honu-operator precedence associativity binary unary) + (when (and (procedure? binary) + (not (procedure-arity-includes? binary 2))) (raise-type-error 'define-honu-operator/syntax "procedure (arity 2)" - proc)) - (-make-honu-operator precedence associativity proc)) + binary)) + (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)) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index 3f40ee47f9..378161642d 100644 --- a/collects/honu/core/read.rkt +++ b/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)) "*/")) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index afefbf576b..e9459e5fb1 100644 --- a/collects/honu/main.rkt +++ b/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) diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt new file mode 100644 index 0000000000..4b859d08d9 --- /dev/null +++ b/collects/honu/private/common.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(provide sqr) +(define (sqr x) (* x x))