From afdd5c4393576b823c8c042c035aea2fe8ef1891 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 3 Oct 2012 12:25:31 -0600 Subject: [PATCH] [honu] support postfix unary operators --- collects/honu/core/private/honu2.rkt | 8 ++--- collects/honu/core/private/operator.rkt | 35 +++++++++++++++------- collects/honu/core/private/parse2.rkt | 25 ++++++++++++---- collects/honu/core/private/transformer.rkt | 31 +++++++++++++++---- collects/tests/honu/operators.honu | 10 ++++++- 5 files changed, 82 insertions(+), 27 deletions(-) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index ff8bb11afa..87618f1fdd 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -148,18 +148,18 @@ (define-honu-syntax define-make-honu-binary-operator (lambda (code) (syntax-parse code - [(_ name:id level:number association:honu-expression function:honu-expression . rest) + [(_ name:id level:honu-expression association:honu-expression function:honu-expression . rest) (define out (racket-syntax - (define-binary-operator name level association.result function.result))) + (define-binary-operator name level.result association.result function.result))) (values out #'rest #t)]))) (provide define-make-honu-unary-operator) (define-honu-syntax define-make-honu-unary-operator (lambda (code) (syntax-parse code - [(_ name:id function:honu-expression . rest) + [(_ name:id level:honu-expression postfix?:honu-expression function:honu-expression . rest) (define out (racket-syntax - (define-unary-operator name function.result))) + (define-unary-operator name level.result postfix?.result function.result))) (values out #'rest #t)]))) ;; equals can have a compile time property that allows it to do something like set! diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt index e273db2f64..d90c6e1cd7 100644 --- a/collects/honu/core/private/operator.rkt +++ b/collects/honu/core/private/operator.rkt @@ -12,9 +12,9 @@ (define-syntax (define-honu-operator/syntax stx) (syntax-parse stx [(_ name precedence associativity binary-function) - (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function #f)))] - [(_ name precedence associativity binary-function unary-function) - (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function unary-function)))])) + (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function #f #f)))] + [(_ name precedence associativity binary-function unary-function postfix?) + (syntax/loc stx (define-syntax name (make-honu-operator precedence associativity binary-function unary-function postfix?)))])) (define-syntax (define-honu-fixture stx) (syntax-parse stx @@ -29,14 +29,29 @@ [right right]) (racket-syntax (operator left right)))))) -(define-syntax-rule (define-unary-operator name operator) - ;; precedence and associativity dont matter for unary - (define-honu-operator/syntax name 0 'left +(define-syntax-rule (define-unary+binary-operator name precedence associativity operator) + (define-honu-operator/syntax name precedence associativity + ;; binary + (lambda (left right) + (with-syntax ([left left] + [right right]) + (racket-syntax (operator left right)))) + ;; unary + (lambda (arg) + (with-syntax ([arg arg]) + (racket-syntax (operator arg)))) + ;; binary operators should not be able to be postfix + #f)) + +(define-syntax-rule (define-unary-operator name precedence postfix? operator) + ;; associativity dont matter for unary + (define-honu-operator/syntax name precedence 'left #f ;; unary (lambda (argument) (with-syntax ([argument (honu->racket argument)]) - (racket-syntax (operator argument)))))) + (racket-syntax (operator argument)))) + postfix?)) (define-honu-operator/syntax honu-flow 0.001 'left (lambda (left right) @@ -90,8 +105,8 @@ (define-honu-operator-= honu-*= *) (define-honu-operator-= honu-/= /) -(define-binary-operator honu-+ 1 'left +) -(define-binary-operator honu-- 1 'left -) +(define-unary+binary-operator honu-+ 1 'left +) +(define-unary+binary-operator honu-- 1 'left -) (define-binary-operator honu-* 2 'left *) (define-binary-operator honu-/ 2 'left /) (define-binary-operator honu-^ 2 'right expt) @@ -111,7 +126,7 @@ (lambda (left right) (for/list ([i (in-range left right)]) i))) -(define-unary-operator honu-not not) +(define-unary-operator honu-not 0.7 #f not) (define-binary-operator honu-== 1 'left equal?) (define-binary-operator honu-not-equal 1 'left (lambda (left right) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index d6dbbfcdd3..0ca8e71003 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -390,10 +390,14 @@ (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)) - (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 operator (syntax-local-value #'head)) + + (define new-precedence (transformer:operator-precedence operator)) + (define association (transformer:operator-association operator)) + (define binary-transformer (transformer:operator-binary-transformer operator)) + (define unary-transformer (transformer:operator-unary-transformer operator)) + (define postfix? (transformer:operator-postfix? operator)) + (define higher (case association [(left) >] @@ -409,7 +413,10 @@ (if current (if binary-transformer (binary-transformer (parse-all-expression current) right) - (error 'binary "cannot be used as a binary operator in ~a" #'head)) + ;; use a unary transformer in postfix position + (if (and postfix? unary-transformer) + (unary-transformer current) + (error 'binary "cannot be used as a binary operator in ~a" #'head))) (if unary-transformer (unary-transformer right) (error 'unary "cannot be used as a unary operator in ~a" #'head)))) @@ -425,7 +432,13 @@ ;; if we have a unary transformer then we have to keep parsing (if unary-transformer (if current - (values (left current) stream) + (if postfix? + (do-parse #'(rest ...) + precedence + left + (unary-transformer current)) + (values (left current) stream)) + (do-parse #'(rest ...) new-precedence (lambda (stuff) (define right (parse-all stuff)) diff --git a/collects/honu/core/private/transformer.rkt b/collects/honu/core/private/transformer.rkt index eb829720db..59a2c2d9e4 100644 --- a/collects/honu/core/private/transformer.rkt +++ b/collects/honu/core/private/transformer.rkt @@ -27,17 +27,36 @@ (provide (rename-out [prop:honu-operator? honu-operator?]) make-honu-operator (rename-out [-honu-operator-ref honu-operator-ref])) + (define-values (prop:honu-operator prop:honu-operator? prop:honu-operator-ref) (make-struct-type-property 'honu-operator)) #; (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 4 0 #f - (list (list prop:honu-operator #t)) - (current-inspector) 0)) -(define (make-honu-operator precedence associativity binary unary) +(define operator-fields '(precedence assocation binary unary postfix?)) + +(define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!) + (make-struct-type 'honu-operator #f (length operator-fields) 0 #f + (list (list prop:honu-operator #t)) + (current-inspector) + 0)) + +(define (get n) + (lambda (operator) + (-honu-operator-ref operator n))) + +(provide operator-precedence operator-association + operator-binary-transformer operator-unary-transformer + operator-postfix?) + +(define operator-precedence (get 0)) +(define operator-association (get 1)) +(define operator-binary-transformer (get 2)) +(define operator-unary-transformer (get 3)) +(define operator-postfix? (get 4)) + +(define (make-honu-operator precedence associativity binary unary postfix?) (when (and (procedure? binary) (not (procedure-arity-includes? binary 2))) (raise-type-error @@ -50,4 +69,4 @@ 'define-honu-operator/syntax "procedure (arity 1)" unary)) - (-make-honu-operator precedence associativity binary unary)) + (-make-honu-operator precedence associativity binary unary postfix?)) diff --git a/collects/tests/honu/operators.honu b/collects/tests/honu/operators.honu index 08a338ca1a..44c5cbb218 100644 --- a/collects/tests/honu/operators.honu +++ b/collects/tests/honu/operators.honu @@ -17,6 +17,14 @@ binary_operator b1 2 'left 3 b1 8 -unary_operator u1 function(x){ x - 2 } +unary_operator u1 4 true function(x){ x - 2 } 2 + u1 u1 5 + +unary_operator u2 5 true function(x){ x + 8 } +unary_operator u3 5 true function(x){ x * 2 }; + +7 u3; +u2 7 u3; +1 + u2 7 u3; +1 + u2 7 u3 * 3;