diff options
author | Masaya Tojo <masaya@tojo.tokyo> | 2024-09-04 00:37:27 +0900 |
---|---|---|
committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-09-04 00:37:27 +0900 |
commit | 0b5bb6dd3f81e12798a13deff22d74528a545211 (patch) | |
tree | a3d3b60f8e4679d20c2708ef4469791314b29769 | |
parent | 7460f2ae88e656ab57e5682d5689f5521e397437 (diff) |
Support unary operator
-rw-r--r-- | qklib/infix.scm | 41 | ||||
-rw-r--r-- | qklib/infix/rule-set.scm | 11 |
2 files changed, 38 insertions, 14 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))) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm index f193055..5d8908a 100644 --- a/qklib/infix/rule-set.scm +++ b/qklib/infix/rule-set.scm @@ -31,6 +31,7 @@ unit? unit-value unit-inv? + unit-unary? prefix prefix? @@ -123,12 +124,14 @@ (make-prefix symbol fix?)))) (define-record-type <unit> - (make-unit value inv?) + (make-unit value inv? unary?) unit? (value unit-value) - (inv? unit-inv?)) + (inv? unit-inv?) + (unary? unit-unary?)) (define unit (case-lambda - ((value) (make-unit value #f)) - ((value inv?) (make-unit value inv?)))))) + ((value) (unit value #f)) + ((value inv?) (unit value inv? #f)) + ((value inv? unary?) (make-unit value inv? unary?)))))) |