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

[honu] set associativty for operators

Browse Source
This commit is contained in:
Jon Rafkind 2011-08-10 10:14:15 -06:00
parent 91068e4085
commit c8695ddf2e
5 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -73,22 +73,24 @@
(lambda (code context)
(syntax-parse code
[(_ expression rest ...)
(values #'(quasiquote expression) #'(rest ...) #f)])))
(values #'(quasiquote expression)
#'(rest ...)
#f)])))
(define-syntax-rule (define-binary-operator name precedence operator)
(define-syntax-rule (define-binary-operator name precedence associativity operator)
(begin
(provide name)
(define-honu-operator/syntax name precedence
(define-honu-operator/syntax name precedence associativity
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(operator left right))))))
(define-binary-operator honu-+ 1 +)
(define-binary-operator honu-- 1 -)
(define-binary-operator honu-* 2 *)
(define-binary-operator honu-/ 2 /)
(define-binary-operator honu-^ 2 expt)
(define-binary-operator honu-and 0.5 and)
(define-binary-operator honu-or 0.5 or)
(define-binary-operator honu-cons 0.1 cons)
(define-binary-operator honu-+ 1 'left +)
(define-binary-operator honu-- 1 'left -)
(define-binary-operator honu-* 2 'left *)
(define-binary-operator honu-/ 2 'left /)
(define-binary-operator honu-^ 2 'right expt)
(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)

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

@ -7,5 +7,5 @@
(provide define-honu-operator/syntax)
(define-syntax (define-honu-operator/syntax stx)
(syntax-parse stx
[(_ name precedence function)
#'(define-syntax name (make-honu-operator precedence function))]))
[(_ name precedence associativity function)
#'(define-syntax name (make-honu-operator precedence associativity function))]))

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

@ -173,8 +173,8 @@
(more-parsing . rest)))))]
[(honu-operator? #'head)
(define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
(define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 1))
(define association 'left)
(define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
(define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2))
(define higher
(case association
[(left) >]

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

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

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

@ -33,6 +33,7 @@
(define-lex-abbrev string-character (:or (:: #\\ any-char)
(:~ #\")))
(define-lex-abbrev string (:: #\" (:* string-character) #\"))
(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^"))
(define-lex-abbrev block-comment (:: "/*"
(complement (:: any-string "*/" any-string))
"*/"))
@ -68,10 +69,11 @@
["!" (token-identifier '!)]
["'" (token-identifier 'quote)]
["`" (token-identifier 'quasiquote)]
["=" (token-identifier '=)]
["*" (token-identifier '*)]
["/" (token-identifier '/)]
["+" (token-identifier '+)]
;; ["=" (token-identifier '=)]
[operator (token-identifier (string->symbol lexeme))]
;; ["*" (token-identifier '*)]
;; ["/" (token-identifier '/)]
;; ["+" (token-identifier '+)]
[";" (token-identifier '|;|)]
;; strip the quotes from the resulting string
;; TODO: find a more optimal way
@ -342,7 +344,7 @@
(define (do-parse current tokens table)
(define (fail tokens)
(if (null? tokens)
(error 'parse "error while parsing")
(error 'read "error while reading")
(let ([first (car tokens)])
;; hack to get the current failure behavior
(do-parse current '() table)