From eaca26b791f4a7a716b61cabd908e7763fea474c Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Tue, 3 Sep 2024 13:20:01 +0900
Subject: Update infix->prefix procedure

---
 qklib/infix.scm | 42 +++++++++++++++++++-----------------------
 1 file changed, 19 insertions(+), 23 deletions(-)

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 6dc68fb..3f9038b 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -30,7 +30,7 @@
         (operator '- 1 'left (unit 0 #t))
         (operator '* 2 'left (unit 1))
         (operator '/ 2 'left (unit 1 #t))
-        (operator '^ 3 'right #f (prefix 'expt)))))
+        (operator '^ 3 'right #f (prefix 'expt #t)))))
 
     (define current-operator-rule-set
       (make-parameter (make-default-operator-rule-set)))
@@ -63,43 +63,39 @@
           expr))
 
     (define (infix->prefix-1 expr rs fail)
-      (define (not-single-error x)
-        (fail (make-compound-condition
-               (condition (&infix-error (expr x)))
-               (condition (&message (message "Invalid infix operator usage"))))))
       (cond ((minimum-precedence expr rs)
              => (lambda (op)
                   (let ->prefix ((expr (list-copy expr))
                                  (op op))
-                    (define (make-prefix left op right)
+                    (define (make-prefix left op-sym right)
+                      (define (->infix left op-sym right)
+                        (append left (cons op-sym right)))
                       (let ((left-op (minimum-precedence left rs))
                             (right-op (minimum-precedence right rs)))
                         (cond ((and (operator? left-op) (operator? right-op))
-                               (list op
+                               (list op-sym
                                      (->prefix left left-op)
                                      (->prefix right right-op)))
                               ((operator? left-op)
                                (if (single? right)
-                                   `(,op ,(->prefix left left-op) ,(car right))
-                                   (not-single-error (append left (cons op right)))))
+                                   (list op-sym (->prefix left left-op) (car right))
+                                   (fail (->infix left op-sym right))))
                               ((operator? right-op)
                                (if (single? left)
-                                   `(,op ,(car left) ,(->prefix right right-op))
-                                   (not-single-error (append left (cons op right)))))
+                                   (list op-sym (car left) (->prefix right right-op))
+                                   (fail (->infix left op-sym right))))
                               (else
                                (if (and (single? left) (single? right))
-                                   `(,op ,(car left) ,(car right))
-                                   (not-single-error (append left (cons op right))))))))
-                    (cond ((single? expr) (operator-symbol op))
-                          ((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 rev-rest) (car+cdr op+rev-rest)))
-                                 (make-prefix (reverse! rev-rest) op (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))))))))
+                                   (list op-sym (car left) (car right))
+                                   (fail (->infix left op-sym right)))))))
+                    (if (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)))))
+                        (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 expr)
-- 
cgit v1.2.3