suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[honu] support postfix unary operators

Browse Source
This commit is contained in:
Jon Rafkind 2012-10-03 12:25:31 -06:00
parent 84b334168b
commit afdd5c4393
5 changed files with 82 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/honu/core/private/honu2.rkt
View File

@ -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!

35
collects/honu/core/private/operator.rkt
View File

@ -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)

25
collects/honu/core/private/parse2.rkt
View File

@ -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))

31
collects/honu/core/private/transformer.rkt
View File

@ -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?))

10
collects/tests/honu/operators.honu
View File

@ -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;