Fix to handle unary operator

1 files changed, 48 insertions, 46 deletions

diff --git a/infix-to-prefix.scm b/infix-to-prefix.scm
index 00e8cc9..3e8b4ca 100644
--- a/infix-to-prefix.scm
+++ b/infix-to-prefix.scm
@@ -52,17 +52,19 @@
          (infix->prefix expr (lambda (e) #f)))))
 
     (define (infix->prefix-1 expr rs fail)
-      (cond ((and (pair? expr) (null? (cdr expr))) (car expr))
-            ((minimum-precedence expr rs)
-             => (lambda (op)
-                  (let ->prefix ((expr (list-copy expr))
-                                 (op op))
-                    (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))
-                            (not-binary-only? (not (operator-prefix-binary-only? op))))
+      (if (and (pair? expr) (null? (cdr expr)))
+          (car expr)
+          (let-values (((op unary?) (minimum-precedence expr rs)))
+            (if op
+                (let ->prefix ((expr (list-copy expr))
+                               (op op)
+                               (unary? unary?))
+                  (define (make-prefix left op-sym right)
+                    (define (->infix left op-sym right)
+                      (append left (cons op-sym right)))
+                    (let-values (((left-op left-unary?) (minimum-precedence left rs))
+                                 ((right-op right-unary?) (minimum-precedence right rs)))
+                      (let ((not-binary-only? (not (operator-prefix-binary-only? op))))
                         `(,(operator-prefix-symbol op)
                           ,@(if (operator? left-op)
                                 (if (eqv? (operator-symbol op) (operator-symbol left-op))
@@ -70,12 +72,12 @@
                                         (if (and (eqv? op-sym (car left))
                                                  (pair? (cdr left))
                                                  (null? (cdr (cdr left))))
-                                            (list (->prefix left left-op))
-                                            (cdr (->prefix left left-op)))
+                                            (list (->prefix left left-op left-unary?))
+                                            (cdr (->prefix left left-op left-unary?)))
                                         (if (operator-left? op)
-                                            (list (->prefix left left-op))
+                                            (list (->prefix left left-op left-unary?))
                                             (fail expr)))
-                                    (list (->prefix left left-op)))
+                                    (list (->prefix left left-op left-unary?)))
                                 (if (and (pair? left)
                                          (null? (cdr left)))
                                     (if (and not-binary-only?
@@ -89,11 +91,11 @@
                           ,@(if (operator? right-op)
                                 (if (eqv? (operator-symbol op) (operator-symbol right-op))
                                     (if not-binary-only?
-                                        (cdr (->prefix right right-op))
+                                        (cdr (->prefix right right-op right-unary?))
                                         (if (operator-right? op)
-                                            (list (->prefix right right-op))
+                                            (list (->prefix right right-op right-unary?))
                                             (fail expr)))
-                                    (list (->prefix right right-op)))
+                                    (list (->prefix right right-op right-unary?)))
                                 (if (and (pair? right)
                                          (null? (cdr right)))
                                     (if (and not-binary-only?
@@ -103,25 +105,24 @@
                                              (eqv? (operator-symbol op) (car (car right))))
                                         (cdr (car right))
                                         (list (car right)))
-                                    (fail (->infix left op-sym right)))))))
-                    (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)))
-                                 (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)))
+                                    (fail (->infix left op-sym right))))))))
+
+                  (cond (unary?
+                         (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
+                           (let-values (((op-sym rest) (car+cdr op+rest)))
+                             (infix->prefix-1 (append lst (list (list op-sym (infix->prefix-1 rest rs fail))))
+                                              rs
+                                              fail))))
+                        ((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))))))
+                        (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))))))
+                expr))))
 
     (define prefix->infix
       (case-lambda
@@ -220,20 +221,21 @@
       (let loop ((expr expr)
                  (min #f)
                  (min-precedence +inf.0)
+                 (min-unary? #f)
                  (prev #t))
         (if (null? expr)
-            min
+            (values min min-unary?)
             (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))))
+                        (let-values (((precedence current-unary?)
+                                      (if (and (operator-identity-unary? current)
+                                               prev)
+                                          (values (operator-identity-unary-precedence current) #t)
+                                          (values (operator-precedence current) #f))))
                           (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))))))
+                              (loop (cdr expr) current precedence current-unary? current)
+                              (loop (cdr expr) min min-precedence min-unary? current)))))
+                  (else (loop (cdr expr) min min-precedence min-unary? #f))))))
 
     (define (operator-identity-inv? x)
       (cond ((operator-identity x) => (cut identity-inv? <>))