diff options
| -rw-r--r-- | autoload.c | 22 | ||||
| -rw-r--r-- | stdlib/infix.tl | 174 |
2 files changed, 196 insertions, 0 deletions
@@ -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)) |