From 11277783121140002ba19885690756de17d88538 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 14 Sep 2024 16:13:57 +0900 Subject: Add support for unary minus operator --- qklib/infix.scm | 86 +++++++++++++++++++++++++++++++++------------------------ 1 file changed, 50 insertions(+), 36 deletions(-) (limited to 'qklib/infix.scm') diff --git a/qklib/infix.scm b/qklib/infix.scm index 2ea093b..d8748d6 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -27,10 +27,10 @@ (list (operator '= 0) (operator '+ 1 (direction 'left #t) (identity 0)) - (operator '- 1 (direction 'left) (identity 0 #t #t)) + (operator '- 1 (direction 'left) (identity 0 #t #t 3)) (operator '* 2 (direction 'left #t) (identity 1)) (operator '/ 2 (direction 'left) (identity 1 #t)) - (operator '^ 3 (direction 'right) #f (prefix #t 'expt))))) + (operator '^ 4 (direction 'right) #f (prefix #t 'expt))))) (define current-operator-rule-set (make-parameter (make-default-operator-rule-set))) @@ -48,18 +48,6 @@ (define (infix->prefix-1 expr rs fail) (cond ((and (pair? expr) (null? (cdr expr))) (car expr)) - ((and (pair? expr) (null? (cdr (cdr expr))) - (rule-set-infix-ref rs (car expr))) - => (lambda (op) - (if (operator-identity-unary? op) - (let ((arg (car (cdr expr))) - (identity (operator-identity op))) - (if (rule-set-infix-ref rs arg) - (fail expr) - (if (identity-inv? identity) - expr - arg))) - (fail expr)))) ((minimum-precedence expr rs) => (lambda (op) (let ->prefix ((expr (list-copy expr)) @@ -74,7 +62,11 @@ ,@(if (operator? left-op) (if (eqv? (operator-symbol op) (operator-symbol left-op)) (if not-binary-only? - (cdr (->prefix left left-op)) + (if (and (eqv? op-sym (car left)) + (pair? (cdr left)) + (null? (cdr (cdr left)))) + (list (->prefix left left-op)) + (cdr (->prefix left left-op))) (if (operator-left? op) (list (->prefix left left-op)) (fail expr))) @@ -100,22 +92,30 @@ (if (and (pair? right) (null? (cdr right))) (if (and not-binary-only? - (or (operator-left? op) + (or (operator-right? op) (operator-associative? op)) (pair? (car right)) (eqv? (operator-symbol op) (car (car right)))) (cdr (car right)) (list (car right))) (fail (->infix left op-sym right))))))) - (cond ((operator-right? op) - (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr))) - (let-values (((op rest) (car+cdr op+rest))) - (make-prefix lst op rest)))) - (else + (cond ((operator-left? op) (let ((rev-expr (reverse! expr))) (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr))) (let-values (((op-sym rev-rest) (car+cdr op+rev-rest))) - (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))))) + (if (and (or (null? rev-rest) + (rule-set-infix-ref rs (car rev-rest))) + (and (pair? rev-lst) + (null? (cdr rev-lst)))) + (infix->prefix-1 (append-reverse! rev-rest + (list `(,op-sym ,(car rev-lst)))) + rs + fail) + (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst))))))) + (else + (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr))) + (let-values (((op rest) (car+cdr op+rest))) + (make-prefix lst op rest)))))))) (else expr))) (define prefix->infix @@ -152,7 +152,9 @@ => (lambda (u) (if (identity-inv? u) (if (identity-unary? u) - (values `(,op-sym ,r-expr) -inf.0) + (values `(,op-sym ,r-expr) + (or (operator-identity-unary-precedence op) + +inf.0)) (values `(,(identity-value (operator-identity op)) ,op-sym ,@(if (or (operator-right? op) @@ -210,19 +212,23 @@ (else (values (map ->infix-fst expr) -inf.0))))))) (define (minimum-precedence expr rs) - (let ((dummy (operator 'dummy +inf.0 'both))) - (let ((result - (fold (lambda (x y-op) - (cond ((rule-set-infix-ref rs x) - => (lambda (x-op) (if (<= (operator-precedence x-op) (operator-precedence y-op)) - x-op - y-op))) - (else y-op))) - dummy - expr))) - (if (eq? dummy result) - #f - result)))) + (let loop ((expr expr) + (min #f) + (min-precedence +inf.0) + (prev #t)) + (if (null? expr) + min + (cond ((rule-set-infix-ref rs (car expr)) + => (lambda (current) + (let ((precedence + (if (and (operator-identity-unary? current) + prev) + (operator-identity-unary-precedence current) + (operator-precedence current)))) + (if (<= precedence min-precedence) + (loop (cdr expr) current precedence current) + (loop (cdr expr) min min-precedence current))))) + (else (loop (cdr expr) min min-precedence #f)))))) (define (operator-identity-inv? x) (cond ((operator-identity x) => (cut identity-inv? <>)) @@ -232,6 +238,14 @@ (cond ((operator-identity op) => identity-unary?) (else #f))) + (define (operator-identity-unary-precedence op) + (cond ((operator-identity op) => + (lambda (id) + (cond ((identity-unary-precedence id) + => (lambda (p) p)) + (else (operator-precedence op))))) + (else #f))) + (define (operator-prefix-binary-only? op) (cond ((operator-prefix op) => prefix-binary-only?) (else #f))) -- cgit v1.2.3