path: root/stdlib/infix.tl

;; 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))

(defvar *ifx-env*)

(defstruct (ifx-oper prec sym) nil
  sym
  lispsym
  (assoc :left)
  (arity :infix)
  prec
  funp
  power

  (: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 0 '=) arity :prefix assoc :right lispsym 'identity)

(new (ifx-oper 10 ':=) assoc :right lispsym 'set)
(new (ifx-oper 10 '+=) lispsym 'inc)
(new (ifx-oper 10 '-=) lispsym 'dec)
(new (ifx-oper 10 '*=) lispsym 'mul)
(new (ifx-oper 10 '/=) lispsym 'div)
(new (ifx-oper 10 '%=) lispsym 'sys:mod-set)
(new (ifx-oper 10 '&&=) lispsym 'sys:and-set)
(new (ifx-oper 10 '||=) lispsym 'sys:or-set)
(new (ifx-oper 10 '|=) lispsym 'sys:logior-set)
(new (ifx-oper 10 '~=) lispsym 'sys:logxor-set)
(new (ifx-oper 10 '&=) lispsym 'sys:logand-set)
(new (ifx-oper 10 '>>=) lispsym 'sys:asr-set)
(new (ifx-oper 10 '<<=) lispsym 'sys:ash-set)

(new (ifx-oper 11 'or))
(new (ifx-oper 11 '||) lispsym 'or)
(new (ifx-oper 12 'and))
(new (ifx-oper 12 '&&) lispsym 'and)
(new (ifx-oper 13 'not) arity :prefix assoc :right)
(new (ifx-oper 13 '!) arity :prefix assoc :right lispsym 'not)

(new (ifx-oper 20 '=) assoc :right)
(new (ifx-oper 20 '!=) assoc :right lispsym '/=)
(new (ifx-oper 20 'eq) assoc :right)
(new (ifx-oper 20 'eql) assoc :right)
(new (ifx-oper 20 'equal) assoc :right)
(new (ifx-oper 20 'neq) assoc :right)
(new (ifx-oper 20 'neql) assoc :right)
(new (ifx-oper 20 'nequal) assoc :right)

(new (ifx-oper 20 '<) assoc :right)
(new (ifx-oper 20 '>) assoc :right)
(new (ifx-oper 20 '<=) assoc :right)
(new (ifx-oper 20 '>=) assoc :right)
(new (ifx-oper 20 'less) assoc :right)
(new (ifx-oper 20 'greater) assoc :right)
(new (ifx-oper 20 'lequal) assoc :right)
(new (ifx-oper 20 'gequal) assoc :right)

(new (ifx-oper 26 '|) lispsym 'logior)
(new (ifx-oper 26 '~) lispsym 'logxor)
(new (ifx-oper 28 '&) lispsym 'logand)

(new (ifx-oper 29 '<<) lispsym 'ash)
(new (ifx-oper 29 '>>) lispsym 'sys:asr)

(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 35 '~) arity :prefix assoc :right lispsym 'lognot)

(new (ifx-oper 40 '*))
(new (ifx-oper 40 '/))
(new (ifx-oper 40 '//) lispsym 'floor)
(new (ifx-oper 40 '%) lispsym 'mod)

(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)

(defmacro sys:mod-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (mod (,getter) ,value))))

(defmacro sys:and-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (and (,getter) ,value))))

(defmacro sys:or-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (or (,getter) ,value))))

(defmacro sys:logand-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (logand (,getter) ,value))))

(defmacro sys:logxor-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (logxor (,getter) ,value))))

(defmacro sys:logior-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (logior (,getter) ,value))))

(defmacro sys:ash-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (ash (,getter) ,value))))

(defmacro sys:asr-set (place value :env env)
  (with-update-expander (getter setter) place env
    ^(,setter (ash (,getter) (- ,value)))))

(defmacro sys:asr (num bits)
  ^(ash ,num (- ,bits)))

(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 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)
                 (if oper.power
                    (push ^(expt ,(pop nodestack) ,oper.power)
                      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)))
        ((@(with @(@o1 [(if ucheck ifx-uops ifx-ops)]) @prec o1.prec) . @rest)
         (unless (or rest (eq o1.arity :postfix))
           (infix-error oexp "operator ~s needs right operand" o1.sym))
         (if (eq o1.arity :infix)
           (iflet ((uo [take-while ifx-uops rest]))
             (set prec (min prec
                            (pred (find-min-key uo :
                                                (opip ifx-uops .prec)))))))
         (if (meq o1.arity :infix :postfix)
           (whilet ((o2 (first opstack))
                    (yes (when o2 (caseq o2.assoc
                                    (:left  (>= o2.prec prec))
                                    (:right (> o2.prec prec))))))
              (pop opstack)
              (add-node o2)))
         (cond
           ((eq o1.arity :postfix)
            (add-node o1)
            (set ucheck nil))
           (t
            (when-match (** @arg . @rrest) rest
              (set o1 (copy o1)
                   o1.power arg
                   rest rrest))
            (push o1 opstack)
            (set ucheck t)))
         (set exp rest))
        ((@(@o [ifx-ops]) . @nil)
         (infix-error oexp "operator ~s needs left operand" o.sym))
        ((@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 ~s" tok))
         (if (consp tok)
           (push ^@,tok nodestack)
           (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 finish-infix
  (((@(memq @op '(and or + - * / logand logior logxor))
     (@op @a0 @a1 . @resta) @b . @restb))
   (finish-infix ^(,op ,a0 ,a1 ,*resta ,b ,*restb)))
  (((@(memq @op '(expt and))
     @a (@op @b0 @b1 . @restb)))
   (finish-infix ^(,op ,a ,b0 ,b1 ,*restb)))
  (((@(memq @o0 '#1=(eq eql equal
                     neq neql nequal . #2=(= /= < > <= >=
                                           less greater lequal gequal)))
      @a (@(memq @o1 '#1#) @b . @restb)))
   (cond
     ((or (and (atom b) (not (macro-form-p b *ifx-env*)))
          (if-match (@(meq @nil 'sys:var 'sys:expr) @(atom)) b t))
      (finish-infix ^(and (,o0 ,a ,b) ,(finish-infix ^(,o1 ,b ,*restb)))))
     ((with-gensyms (bg)
        ^(let (,bg)
          ,(finish-infix ^(and (,o0 ,a (set ,bg ,b))
                               ,(finish-infix ^(,o1 ,bg ,*restb)))))))))
  (((and @(sme (@(memq @op '#2#)) nil (@b) a) (@op @b . @restb) . @rest))
   (finish-infix ^(and (,op ,*(butlast a) ,b ,*restb) ,*rest)))
  (((and @expr))
   expr)
  (((@(eq 'sys:expr) @expr))
   expr)
  (((@op . @args))
   (identity (cons op [mapcar finish-infix args])))
  ((@else) else))

(defmacro funp (env sym)
  ^(unless (consp ,sym)
     (or (fboundp ,sym) (lexical-fun-p ,env ,sym))))

(defun-match detect-infix
  (((@x @y . @rest) @env)
   (let* ((xu [ifx-uops x])
          (yu [ifx-uops y])
          (yo [ifx-ops y])
          (yb (if-match [. @toks] y
                (or (and (consp toks)
                         (null (cdr toks)))
                    (detect-infix toks env))))
          (ya (and (not yu) (not yo) (not (funp env y))))
          (xa (and (not xu) (not (funp env x)))))
     (or
       (and xa (or yo yb))
       (and xu ya (neq xu.sym xu.lispsym) (null rest))
       (and xu (eq y '**) (eq xu.sym xu.lispsym))
       (if-match (@z . @nil) rest
         (let* ((zu [ifx-uops z])
                (zo [ifx-ops z])
                (za (and (not zu) (not zo) (not (funp env z)))))
           (or
             (and xu ya (neq xu.sym xu.lispsym) (not za))
             (and xu yu (or zu za (eq z '**)))
             (and xu ya zo))))))))

(defun infix-expand-hook (exp env type-sym)
  (ignore env)
  (cond
    ((eq type-sym :macro) exp)
    ((and (meq type-sym :fun nil) (detect-infix exp env))
     (let ((*ifx-env* env))
       (finish-infix (parse-infix exp))))
    ((match-case exp
       ([] exp)
       ([. @nil] exp)
       (@(require (@tok)
                  (null type-sym)
                  (or (not (bindable tok))
                      (lexical-var-p env tok)
                      (boundp tok)))
         tok)
       (@(require (@x @y . @rest)
                  (consp rest)
                  (and (not (funp env x)) (funp env y)))
        (let ((rexp (infix-expand-hook rest env nil)))
          (if (eq rexp rest)
            ^(,y ,x ,*rest)
            ^(,y ,x ,rexp))))
       (@(require (@x . @rest)
                  (and (consp rest) (cdr rest) (funp env x)))
        (let ((rexp (infix-expand-hook rest env nil)))
          (if (eq rexp rest)
            exp
            ^(,x ,rexp))))))
    (exp)))

(defmacro usr:ifx (. body)
  ^(expander-let ((*expand-hook* [expand-hook-combine infix-expand-hook
                                                      *expand-hook*]))
     ,*body))