From 561c7a3ea6c5153cde6be6d1792cda5af1202881 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 29 Jun 2022 14:30:35 +0200
Subject: Fix C order of operations.

---
 module/c/parse.scm | 148 ++++++++++++++++++++++++++++++++---------------------
 1 file changed, 90 insertions(+), 58 deletions(-)

(limited to 'module/c/parse.scm')

diff --git a/module/c/parse.scm b/module/c/parse.scm
index d407f5ac..d923e5b1 100644
--- a/module/c/parse.scm
+++ b/module/c/parse.scm
@@ -1,6 +1,7 @@
 (define-module (c parse)
   :use-module (hnh util)
   :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
   :use-module (ice-9 match)
   :export (parse-lexeme-tree))
 
@@ -138,15 +139,21 @@
      `(,(parse-lexeme-tree op)
        ,(parse-lexeme-tree arg))]
 
+    ;; resolved-operator and ternary are the return "types"
+    ;; of resolve-order-of-operations
+    [(('resolved-operator op) args ...)
+     `(,op ,@(map parse-lexeme-tree args))]
+
+    [('ternary a b c)
+     `(ternary ,(parse-lexeme-tree a)
+               ,(parse-lexeme-tree b)
+               ,(parse-lexeme-tree c))]
+
     [('infix args ...)
-     (let ((r
-            (resolve-order-of-operations
-             (flatten-infix (cons 'infix args)))))
-       (match r
-         (`(: (? ,op ,true)
-              ,false)
-          `(ternary ,op ,true ,false))
-         (_ r)))]
+     (let ((r (resolve-order-of-operations
+               (flatten-infix (cons 'infix args)))))
+       (parse-lexeme-tree r))]
+
 
     [('funcall function ('group arguments))
      `(funcall ,(parse-lexeme-tree function)
@@ -220,70 +227,95 @@
 
 (define order-of-operations
   (reverse
-   (concatenate
-    ;; This is only for binary operations
-    `((-> ,(symbol #\.))
-      ;; All unary procedures go here, incnluding typecasts, and sizeof
-      (* / %)
-      (+ -)
-      (<< >>)
-      (< <= > >=)
-      (== != not_eq)
-      (& bitand)
-      (^ xorg)
-      (,(symbol #\|) bitor)
-      (&& and)
-      (,(symbol #\| #\|) or)
-      (? :)
-      (= += -= *= /= %= <<= >>= &= ^= ,(symbol #\| #\=)
-         and_eq or_eq xor_eq)
-      (,(symbol #\,))
-      ))))
-
-(define (mark-other form)
-  (if (list? form) (cons '*other* form) form))
+   ;; This is only for binary operations
+   `((-> ,(symbol #\.))
+     ;; All unary procedures go here, incnluding typecasts, and sizeof
+     (* / %)
+     (+ -)
+     (<< >>)
+     (< <= > >=)
+     (== != not_eq)
+     (& bitand)
+     (^ xorg)
+     (,(symbol #\|) bitor)
+     (&& and)
+     (,(symbol #\| #\|) or)
+     (? :)
+     (= += -= *= /= %= <<= >>= &= ^= ,(symbol #\| #\=)
+        and_eq or_eq xor_eq)
+     (,(symbol #\,))
+     )))
+
+;; a.b->c.d (. (-> (. a b) c) d)
+;; 2 * 3 / 4 * 5 => (* (/ (* 2 3) 4) 5)
+;;         eller => (* 2 (/ 3 4) 5)
 
 (define* (resolve-order-of-operations
           tree optional: (order order-of-operations))
 
-  (format (current-error-port) "~s~%" tree)
   (if (null? order)
       (scm-error 'c-parse-error
                  "resolve-order-of-operations"
                  "Out of operations to resolve when resolving expression ~s"
                  (list tree) #f)
       (match tree
-        [('*other* body ...) body]
-        [(form) (resolve-order-of-operations form order)]
-        [(forms ...)
-         (match (split-by forms (car order))
-           [(group) (resolve-order-of-operations group (cdr order))]
-           [groups
-            (cons (car order)
-                  (map (lambda (form) (resolve-order-of-operations
-                                  form order-of-operations))
-                       groups))])]
-        [a a])))
+        [('fixed-infix form) form]
+        [('fixed-infix forms ...)
+         (match (split-by-one-of forms (car order))
+           [(group)
+            (resolve-order-of-operations (cons 'fixed-infix group)
+                                         (cdr order))]
+           [(a ('? b ...) (': c ...))
+            `(ternary ,(resolve-order-of-operations (cons 'fixed-infix a) (cdr order))
+                      ,(resolve-order-of-operations (cons 'fixed-infix b) (cdr order))
+                      ,(resolve-order-of-operations (cons 'fixed-infix c) (cdr order)))]
+           [(first rest ...)
+            (if (apply eq? (map car rest))
+                (let ((op (caar rest)))
+                  `((resolved-operator ,op)
+                    ,@(map (lambda (x) (resolve-order-of-operations (cons 'fixed-infix x)
+                                                               (cdr order)))
+                           (cons first (map cdr rest)))))
+                (fold (lambda (item done)
+                        (let ((operator args (car+cdr item)))
+                          `((resolved-operator ,operator)
+                            ,done ,(resolve-order-of-operations
+                                    (cons 'fixed-infix args)
+                                    (cdr order)))))
+                      (resolve-order-of-operations (cons 'fixed-infix first)
+                                                   (cdr order))
+                      rest))])])))
+
+;; 1 * 2 / 3 * 4
+;; ⇒ ((1) (* 2) (/ 3) (* 4))
+;; (1)
+;; (* (1) 2)
+;; (/ (* (1) 2) 3)
+;; (* (/ (* (1) 2) 3) 4)
 
 ;; Flatens a tree of infix triples. Stops when it should.
 ;; (parenthesis, function calls, ...)
 (define (flatten-infix form)
-  (match form
-    [('infix left op ('infix right ...))
-     (cons* (parse-lexeme-tree left)
-            (parse-lexeme-tree op)
-            (flatten-infix (cons 'infix right)))]
-
-    [('infix left op right)
-     (list (mark-other (parse-lexeme-tree left))
-           (parse-lexeme-tree op)
-           (mark-other (parse-lexeme-tree right)))]
-
-    [other (scm-error 'c-parse-error
-                      "flatten-infix"
-                      "Not an infix tree ~a"
-                      (list other)
-                      #f)]))
+  (cons 'fixed-infix
+   (let loop ((form form))
+     (match form
+       [('infix left op ('infix right ...))
+        (cons* left
+               (parse-lexeme-tree op)
+               (loop (cons 'infix right)))]
+
+       [('infix left op right)
+        (list left
+              (parse-lexeme-tree op)
+              right)]
+
+       [('infix form) form]
+
+       [other (scm-error 'c-parse-error
+                         "flatten-infix"
+                         "Not an infix tree ~a"
+                         (list other)
+                         #f)]))))
 
 
 
-- 
cgit v1.2.3