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

---
 qklib/infix.scm | 75 ++++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 45 insertions(+), 30 deletions(-)

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 3f9038b..06b7b05 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -98,49 +98,63 @@
                             (make-prefix lst op rest)))))))
             (else expr)))
 
-    (define (prefix->infix expr)
-      (let ((rs (current-operator-rule-set)))
-        (let-values (((result _precedence) (%prefix->infix expr rs)))
-          result)))
+    (define prefix->infix
+      (case-lambda
+        ((expr failure)
+         (let ((rs (current-operator-rule-set)))
+           (call-with-current-continuation
+            (lambda (return)
+              (let-values (((result _precedence) (%prefix->infix expr rs (lambda (e) (return (failure e))))))
+                result)))))
+        ((expr)
+         (prefix->infix expr (lambda (e) #f)))))
 
-    (define (operator-inv? x)
+    (define (operator-unit-inv? x)
       (cond ((operator-unit x) => (cut unit-inv? <>))
             (else #f)))
 
-    (define (%prefix->infix expr rs)
+    (define (%prefix->infix expr rs failure)
       (let ->infix ((expr expr))
         (define (->infix-fst expr)
           (let-values (((x _) (->infix expr)))
             x))
         (if (not (pair? expr))
             (values expr -inf.0)
-            (let-values (((op args) (car+cdr expr)))
-              (cond ((rule-set-prefix-ref rs op)
+            (let-values (((op-prefix-sym args) (car+cdr expr)))
+              (cond ((rule-set-prefix-ref rs op-prefix-sym)
                      => (lambda (op)
                           (let ((p (operator-precedence op))
-                                (sym (operator-symbol op)))
-                            (cond ((and (null? args)
-                                        (not (operator-inv? op))
-                                        (operator-unit op))
-                                   => (lambda (u) (values (unit-value u) -inf.0)))
-                                  ((single? args)
+                                (op-sym (operator-symbol op)))
+                            (define (select x xp)
+                              (if (<= p xp) x (list x)))
+                            (cond ((null? args)
+                                   (cond ((and (not (operator-unit-inv? op))
+                                               (operator-unit op))
+                                          => (lambda (u) (values (unit-value u) -inf.0)))
+                                         (else (failure expr))))
+                                  ((null? (cdr args))
                                    (let-values (((x xp) (->infix (car args))))
-                                     (cond ((operator-inv? op)
+                                     (cond ((operator-unit-inv? op)
                                             (values `(,(unit-value (operator-unit op))
-                                                      ,sym
-                                                      ,@(if (<= p xp) x (list x)))
+                                                      ,op-sym
+                                                      ,@(select x xp))
                                                     p))
                                            ((operator-unit op)
                                             (values x xp))
-                                           (else (values (list sym x) -inf.0)))))
-                                  ((pair? args)
-                                   (values (cdr
-                                            (append-map (lambda (arg)
-                                                          (let-values (((x xp) (->infix arg)))
-                                                            (cons sym (if (<= p xp) x (list x)))))
-                                                        args))
-                                           p))
-                                  (else (values (map ->infix-fst expr) -inf.0))))))
+                                           (else (failure expr)))))
+                                  ((null? (cdr (cdr args)))
+                                   (let-values (((x xp) (->infix (car args)))
+                                                ((y yp) (->infix (cadr args))))
+                                     (values `(,@(select x xp) ,op-sym ,@(select y yp)) p)))
+                                  (else
+                                   (if (and (operator-prefix op)
+                                            (prefix-fix? (operator-prefix op)))
+                                       (failure expr)
+                                       (values (cdr (append-map (lambda (arg)
+                                                                  (let-values (((x xp) (->infix arg)))
+                                                                    (cons op-sym (select x xp))))
+                                                                args))
+                                               p)))))))
                     (else (values (map ->infix-fst expr) -inf.0)))))))
 
     (define (single? x)
@@ -151,10 +165,11 @@
       (let ((dummy (operator 'dummy +inf.0)))
         (let ((result
                (fold (lambda (x y-op)
-                       (let ((x-op (rule-set-infix-ref rs x)))
-                         (cond ((operator? x-op)
-                                (if (<= (operator-precedence x-op) (operator-precedence y-op)) x-op y-op))
-                               (else 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)
-- 
cgit v1.2.3