diff options
Diffstat (limited to 'qklib/infix.scm')
| -rw-r--r-- | qklib/infix.scm | 41 |
1 files changed, 31 insertions, 10 deletions
diff --git a/qklib/infix.scm b/qklib/infix.scm index 06b7b05..ce3d952 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -26,8 +26,8 @@ (define (make-default-operator-rule-set) (rule-set (list - (operator '+ 1 'left (unit 0)) - (operator '- 1 'left (unit 0 #t)) + (operator '+ 1 'left (unit 0 #f #t)) + (operator '- 1 'left (unit 0 #t #t)) (operator '* 2 'left (unit 1)) (operator '/ 2 'left (unit 1 #t)) (operator '^ 3 'right #f (prefix 'expt #t))))) @@ -62,8 +62,26 @@ (map-cars f (cdr expr)))) expr)) + (define (operator-unit-unary? op) + (cond ((operator-unit op) => unit-unary?) + (else #f))) + (define (infix->prefix-1 expr rs fail) - (cond ((minimum-precedence expr rs) + (cond ((and (pair? expr) + (single? (cdr expr)) + (let ((op (rule-set-infix-ref rs (car expr)))) + (if (and op (operator-unit-unary? op)) + op + #f))) + => (lambda (op) + (let ((arg (car (cdr expr))) + (unit (operator-unit op))) + (if (rule-set-infix-ref rs arg) + (fail expr) + (if (unit-inv? unit) + expr + arg))))) + ((minimum-precedence expr rs) => (lambda (op) (let ->prefix ((expr (list-copy expr)) (op op)) @@ -134,13 +152,16 @@ (else (failure expr)))) ((null? (cdr args)) (let-values (((x xp) (->infix (car args)))) - (cond ((operator-unit-inv? op) - (values `(,(unit-value (operator-unit op)) - ,op-sym - ,@(select x xp)) - p)) - ((operator-unit op) - (values x xp)) + (cond ((operator-unit op) + => (lambda (u) + (if (unit-inv? u) + (if (unit-unary? u) + (values `(,op-sym ,x) -inf.0) + (values `(,(unit-value (operator-unit op)) + ,op-sym + ,@(select x xp)) + p)) + (values x xp)))) (else (failure expr))))) ((null? (cdr (cdr args))) (let-values (((x xp) (->infix (car args))) |