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 ++++++++++++++++++++++++++++-------------------- qklib/infix/rule-set.scm | 12 +++++-- 2 files changed, 59 insertions(+), 39 deletions(-) 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))) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm index 1189bca..db0c4e5 100644 --- a/qklib/infix/rule-set.scm +++ b/qklib/infix/rule-set.scm @@ -34,6 +34,7 @@ identity-value identity-inv? identity-unary? + identity-unary-precedence direction direction? @@ -106,6 +107,9 @@ ((symbol precedence direction identity) (operator symbol precedence direction identity #f)) ((symbol precedence direction identity prefix) + (when (and identity (identity-unary? identity) + (not (and direction (direction-left? direction)))) + (error "operator: unary operator must be left direction" symbol)) (make-operator symbol precedence direction identity prefix)))) (define-record-type @@ -160,14 +164,16 @@ (make-prefix binary-only? #t symbol)))) (define-record-type - (make-identity value inv? unary?) + (make-identity value inv? unary? unary-precedence) identity? (value identity-value) (inv? identity-inv?) - (unary? identity-unary?)) + (unary? identity-unary?) + (unary-precedence identity-unary-precedence)) (define identity (case-lambda ((value) (identity value #f)) ((value inv?) (identity value inv? #f)) - ((value inv? unary?) (make-identity value inv? unary?)))))) + ((value inv? unary?) (identity value inv? unary? #f)) + ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence)))))) -- cgit v1.2.3