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

[honu] add moere assignment operators

Browse Source
This commit is contained in:
Jon Rafkind 2012-01-26 13:19:06 -07:00
parent 9e8a77c5c5
commit b67f5e71e6
5 changed files with 33 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/honu/core/main.rkt
View File

@ -65,6 +65,7 @@
[honu-structure struct]
[honu-syntax syntax]
[honu-equal =]
[honu-+= +=]
[literal:honu-prefix prefix]
[literal:honu-then then]
[literal:colon %colon]

2
collects/honu/core/private/literals.rkt
View File

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

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

@ -6,7 +6,8 @@
syntax/parse)
(only-in "literals.rkt" %racket))
(provide define-honu-operator/syntax)
(provide (all-defined-out))
(define-syntax (define-honu-operator/syntax stx)
(syntax-parse stx
[(_ name precedence associativity binary-function)
@ -14,15 +15,12 @@
[(_ 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))]))
(define-syntax-rule (define-binary-operator name precedence associativity operator)
(begin
(provide name)
(define-honu-operator/syntax name precedence associativity
;; binary
(lambda (left right)
@ -32,31 +30,44 @@
;; unary
(lambda (argument)
(with-syntax ([argument argument])
#'(%racket (operator argument)))))))
#'(%racket (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])
#'(%racket (operator argument)))))))
#'(%racket (operator argument))))))
(provide honu-flow)
(define-honu-operator/syntax honu-flow 0.001 'left
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(%racket (right left)))))
(provide honu-equal)
(begin-for-syntax
(define-syntax-rule (mutator change)
(lambda (left right)
(with-syntax ([left left]
[right (change left right)])
#'(%racket (set! left right))))))
;; Traditional assignment operator
(define-honu-operator/syntax honu-equal 0.0001 'left
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(%racket (set! left right)))))
(mutator (lambda (left right) right)))
(define-syntax-rule (define-honu-operator-= name operation)
(define-honu-operator/syntax name 0.0001 'left
(mutator (lambda (left right)
(with-syntax ([left left] [right right])
#'(operation left right))))))
;; Operators that mutate the left hand side
(define-honu-operator-= honu-+= +)
(define-honu-operator-= honu--= -)
(define-honu-operator-= honu-*= *)
(define-honu-operator-= honu-/= /)
(define-binary-operator honu-+ 1 'left +)
(define-binary-operator honu-- 1 'left -)

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

@ -325,7 +325,10 @@
(if unary-transformer
(unary-transformer stuff)
(error 'unary "cannot be used as a unary operator in ~a" #'head))))
(emit-local-step stuff output #:id #'binary-transformer)
#;
(debug "Binary transformer ~a\n" binary-transformer)
#;
(emit-local-step stuff output #:id binary-transformer)
(with-syntax ([out (parse-all output)])
#'(%racket out)))

3
collects/honu/core/read.rkt
View File

@ -36,7 +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))