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

fix parsing for operators

Browse Source
This commit is contained in:
Jon Rafkind 2011-07-14 12:48:21 -06:00
parent 937d0ad722
commit 57a759c383
3 changed files with 66 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,9 +22,27 @@
(do-parse)))
#'rest)])))
(define-syntax-rule (define-binary-operator name precedence operator)
(begin
(provide name)
(define-honu-operator/syntax name precedence
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(operator left right))))))
(provide honu-+)
(define-honu-operator/syntax honu-+ 1
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(+ left right))))
(provide honu--)
(define-honu-operator/syntax honu-- 1
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(- left right))))
(define-binary-operator honu-* 2 *)

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

@ -68,11 +68,34 @@
(and (identifier? what)
((literal-set->predicate check) what)))
;; 1 + 1
;; ^
;; left: identity
;; current: 1
;; 1 + 1
;; ^
;; left: (lambda (x) (+ 1 x))
;; current: #f
;; 1 + 1
;; ^
;; left: (lambda (x) (+ 1 x))
;; current: 1
;;
;; 1 + 1 * 2
;; ^
;; left: (lambda (x) (left (* 1 x)))
;; current: #f
;;
;; 1 + 1 * 2
;; ^
;; left: (lambda (x) (left (* 1 x)))
;; current: 2
(define (parse input)
(define (do-parse stream precedence left current)
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current)
(syntax-parse stream
[() left]
[() (left current)]
[(head rest ...)
(cond
[(honu-macro? #'head)
@ -82,7 +105,7 @@
((syntax-local-value #'head) #'(head rest ...) #f)])
(with-syntax ([parsed parsed]
[rest unparsed])
(do-parse #'rest precedence #'parsed current)
(do-parse #'rest precedence (lambda (x) x) #'parsed)
#;
#'(splicing-let-syntax ([more-parsing (lambda (stx)
(do-parse (stx-cdr stx)
@ -94,39 +117,42 @@
(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 check
(define higher
(case association
[(left) >]
[(right) >=]))
(printf "new precedence ~a\n" new-precedence)
(if (check new-precedence precedence)
(if (higher new-precedence precedence)
(do-parse #'(rest ...) new-precedence
(lambda (stuff)
(operator-transformer left stuff))
current)
(left current))]
(left (operator-transformer current stuff)))
#f)
(do-parse #'(head rest ...)
0
(lambda (x) x)
(left current)))]
[(semicolon? #'head)
(with-syntax ([so-far left])
(with-syntax ([so-far (left current)])
#'(splicing-let-syntax ([more (lambda (stx)
(parse #'(rest ...)))])
so-far (more)))]
[(identifier? #'head)
(do-parse #'(rest ...) precedence #'head current)]
(do-parse #'(rest ...) precedence left #'head)]
[else (syntax-parse #'head
#:literal-sets (cruft)
[x:number (do-parse #'(rest ...)
precedence (left #'x) current)]
precedence left #'x)]
[(#%parens args ...)
(debug "function call ~a\n" left)
(with-syntax ([left left])
#'(left args ...))
(with-syntax ([current current])
#'(current args ...))
#;
(error 'parse "function call")]
[else (error 'what "dont know ~a" #'head)])]
)]))
(do-parse input 0 (lambda (x) x) #'(void)))
(do-parse input 0 (lambda (x) x) #f))
(define (parse2 forms)
(debug "parse forms ~a\n" forms)

10
collects/tests/honu/test.rkt
View File

@ -4,7 +4,9 @@
(prefix-in macro_ honu/core/private/macro2)
(rename-in honu/core/private/honu2
[honu-function honu_function]
[honu-+ honu_plus])
[honu-+ honu_plus]
[honu-* honu_times]
[honu-- honu_minus])
(rename-in honu/core/private/literals
[honu-= =]
[semicolon |;|])
@ -46,3 +48,9 @@
(let ()
(fake-module-begin #hx(1 honu_plus 1)))
(let ()
(fake-module-begin #hx(1 honu_plus 1 honu_minus 4)))
(let ()
(fake-module-begin #hx(1 honu_plus 1 honu_minus 4 honu_times 8)))