aboutsummaryrefslogtreecommitdiff
path: root/qklib/infix.scm
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-09-04 00:37:27 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-09-04 00:37:27 +0900
commit0b5bb6dd3f81e12798a13deff22d74528a545211 (patch)
treea3d3b60f8e4679d20c2708ef4469791314b29769 /qklib/infix.scm
parent7460f2ae88e656ab57e5682d5689f5521e397437 (diff)
Support unary operator
Diffstat (limited to 'qklib/infix.scm')
-rw-r--r--qklib/infix.scm41
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)))