Initial implementation of infix expressions.

The infix module provides a macro called ifx. Forms
(evaluated expressions) enclosed inside ifx at any nesting
level, which are not special operator or macro forms, are
subject to automatic detection of an infix notation, which is
transformed into regular Lisp. The notation is based on Lisp
atoms; no read syntax is introduced. Infix may be freely mixed
with ordinary Lisp.

* autoload.c (infix_set_entries, infix_instantiate):
New static functions.
(autoload_init): Register new infix module for autoload.

* stdlib/infix.tl: New file.

2 files changed, 196 insertions, 0 deletions

diff --git a/autoload.c b/autoload.c
index 43064204..ebc0fb28 100644
--- a/autoload.c
+++ b/autoload.c
@@ -1015,6 +1015,27 @@ static val enum_instantiate(void)
   return nil;
 }
 
+static val infix_set_entries(val fun)
+{
+  val name[] = {
+    lit("parse-infix"), lit("ifx"),
+    nil
+  };
+  val name_noload[] = {
+    lit("+="), lit("-="), lit("**"), lit("++"), lit("--"),
+    nil
+  };
+  autoload_set(al_fun, name, fun);
+  intern_only(name_noload);
+  return nil;
+}
+
+static val infix_instantiate(void)
+{
+  load(scat2(stdlib_path, lit("infix")));
+  return nil;
+}
+
 val autoload_reg(val (*instantiate)(void),
                  val (*set_entries)(val))
 {
@@ -1087,6 +1108,7 @@ void autoload_init(void)
   autoload_reg(csort_instantiate, csort_set_entries);
   autoload_reg(glob_instantiate, glob_set_entries);
   autoload_reg(enum_instantiate, enum_set_entries);
+  autoload_reg(infix_instantiate, infix_set_entries);
 
   reg_fun(intern(lit("autoload-try-fun"), system_package), func_n1(autoload_try_fun));
 }
diff --git a/stdlib/infix.tl b/stdlib/infix.tl
new file mode 100644
index 00000000..31712a10
--- /dev/null
+++ b/stdlib/infix.tl
@@ -0,0 +1,174 @@
+;; Copyright 2025
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice,
+;;    this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvarl ifx-ops (hash))
+(defvarl ifx-uops (hash))
+
+(defstruct (ifx-oper prec sym) nil
+  sym
+  lispsym
+  (assoc :left)
+  (arity :infix)
+  prec
+  funp
+
+  (:postinit (self)
+    (set [(if (meql self.arity :infix :postfix) ifx-ops ifx-uops) self.sym] self
+         self.lispsym (or self.lispsym self.sym))))
+
+;; j0 j1 y0 y1 omitted: they are common variable names.
+(each ((fun '(abs signum isqrt square zerop plusp minusp evenp oddp sin cos tan
+              asin acos atan log log2 log10 exp sqrt width logcount cbrt erf
+              erfc exp10 exp2 expm1 gamma lgamma log1p logb nearbyint
+              rint significand tgamma tofloat toint
+              trunc floor ceil round lognot)))
+  (new (ifx-oper 0 fun) arity :prefix assoc :right funp t))
+
+(new (ifx-oper 10 ':=) lispsym 'set)
+(new (ifx-oper 11 'or))
+(new (ifx-oper 12 'and))
+(new (ifx-oper 13 'not) arity :prefix assoc :right)
+
+(new (ifx-oper 20 '<))
+(new (ifx-oper 20 '>))
+(new (ifx-oper 20 '<=))
+(new (ifx-oper 20 '>=))
+(new (ifx-oper 20 '=))
+(new (ifx-oper 20 'eq))
+(new (ifx-oper 20 'eql))
+(new (ifx-oper 20 'equal))
+(new (ifx-oper 20 'neq))
+(new (ifx-oper 20 'neql))
+(new (ifx-oper 20 'nequal))
+
+(new (ifx-oper 25 '+=) lispsym 'inc)
+(new (ifx-oper 25 '-=) lispsym 'dec)
+
+(new (ifx-oper 30 '-))
+(new (ifx-oper 30 '+))
+
+(new (ifx-oper 35 '-) arity :prefix assoc :right)
+(new (ifx-oper 35 '+) arity :prefix assoc :right)
+
+(new (ifx-oper 40 '*))
+(new (ifx-oper 40 '/))
+
+(new (ifx-oper 50 '**) assoc :right lispsym 'expt)
+
+(new (ifx-oper 55 '++) arity :prefix assoc :right lispsym 'inc)
+(new (ifx-oper 55 '--) arity :prefix assoc :right lispsym 'dec)
+
+(new (ifx-oper 60 '++) arity :postfix assoc :left lispsym 'pinc)
+(new (ifx-oper 60 '--) arity :postfix assoc :left lispsym 'pdec)
+
+(defun infix-error (exp fmt . args)
+  (let ((loc (source-loc-str exp))) 
+    (let ((msg (fmt `@loc: infix: @fmt` . args)))
+      (when (and sys:*load-recursive*
+                 (null (find-frame 'error 'catch-frame)))
+        (dump-deferred-warnings *stderr*)
+        (put-line msg *stderr*))
+      (throw 'eval-error msg))))
+
+(defun usr:parse-infix (exp)
+  (let (nodestack opstack (ucheck t) (oexp exp))
+    (flet ((add-node (oper)
+              (ecaseql oper.arity
+                ((:prefix :postfix)
+                 (push (list oper.lispsym (pop nodestack)) nodestack))
+                ((:infix)
+                 (let ((y (pop nodestack))
+                       (x (pop nodestack)))
+                   (push (list oper.lispsym x y) nodestack))))))
+      (while-true-match-case exp
+        ((@[[chain ifx-uops .?funp] @op] (@arg . @args) . @rest)
+         (set exp ^((,op ,arg ,*args) ,*rest)))
+        ((@[[chain ifx-uops .?funp] @op] () . @rest)
+         (set exp ^((,op) ,*rest)))
+        ((@(@o1 [(if ucheck ifx-uops ifx-ops)]) . @rest)
+         (unless (or rest (eq o1.arity :postfix))
+           (infix-error oexp "operator ~s needs right operand" o1.sym))
+         (if (meq o1.arity :infix :postfix)
+           (whilet ((o2 (first opstack))
+                    (yes (when o2 (caseq o2.assoc
+                                    (:left  (>= o2.prec o1.prec))
+                                    (:right (>  o2.prec o1.prec))))))
+              (pop opstack)
+              (add-node o2)))
+         (cond
+           ((eq o1.arity :postfix)
+            (add-node o1)
+            (set ucheck nil))
+           (t
+            (push o1 opstack)
+            (set ucheck t)))
+         (set exp rest))
+        ((@(@o [ifx-ops]) . @nil)
+         (infix-error oexp "operator ~s needs left operand" o.sym))
+        (([. @args1] [. @args2] . @rest)
+         (set exp ^([[,*args1] ,*args2] ,*rest)))
+        ((@op [. @args] . @rest)
+         (set exp ^([,op ,*args] ,*rest)))
+        ((@op (@arg . @args) . @rest)
+         (set exp ^((,op ,arg ,*args) ,*rest)))
+        ((@op () . @rest)
+         (set exp ^((,op) ,*rest)))
+        ((@tok . @rest)
+         (if (or (not ucheck)
+                 (eq (first opstack).?arity :postfix))
+           (infix-error oexp "operator expected before operand ~s" tok)) 
+         (push tok nodestack)
+         (set ucheck nil
+              exp rest)))
+      (whilet ((o (first opstack)))
+        (pop opstack)
+        (add-node o)))
+    (if (rest nodestack)
+      (infix-error oexp "nodestack extra entries ~s" nodestack))
+    (first nodestack)))
+
+(defun-match infix-expand-hook
+  ((@exp @nil :macro)
+   exp)
+  ((@(as exp (@[ifx-uops] @nil [. @nil] . @nil)) @nil @nil)
+   (usr:parse-infix exp))
+  ((@(as exp (@[ifx-uops] @nil . @rest)) @nil @nil)
+   (if (find-if [orf ifx-uops ifx-ops] rest)
+     (usr:parse-infix exp)
+     exp))
+  ((@(as exp (@x @y . @rest)) @nil @nil)
+   (cond
+     ((or [ifx-uops y] [ifx-ops y]) (usr:parse-infix exp))
+     ((find-if [orf ifx-uops ifx-ops] rest) (usr:parse-infix exp))
+     ((and (not (fboundp x)) (fboundp y)) ^(,y ,x ,*rest))
+     (t exp)))
+  ((@exp @nil @nil) exp))
+
+(defmacro usr:ifx (. body)
+  ^(expander-let ((*expand-hook* [expand-hook-combine infix-expand-hook
+                                                      *expand-hook*]))
+     ,*body))