diff options
| -rw-r--r-- | stdlib/infix.tl | 37 |
1 files changed, 20 insertions, 17 deletions
diff --git a/stdlib/infix.tl b/stdlib/infix.tl index e1e801bb..3d83a6a1 100644 --- a/stdlib/infix.tl +++ b/stdlib/infix.tl @@ -96,7 +96,7 @@ (put-line msg *stderr*)) (throw 'eval-error msg)))) -(defun usr:parse-infix (exp) +(defun parse-infix (exp) (let (nodestack opstack (ucheck t) (oexp exp)) (flet ((add-node (oper) (ecaseql oper.arity @@ -158,22 +158,25 @@ (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)) +(defun-match detect-infix + (((@(@o [ifx-uops]) . @rest)) + (or (neq o.sym o.lispsym) + (find-if [orf ifx-uops ifx-ops] rest))) + (((@nil @y . @rest)) + (or [ifx-uops y] [ifx-ops y] + (find-if [orf ifx-uops ifx-ops] rest))) + ((@nil))) + +(defun infix-expand-hook (exp env type-sym) + (ignore env) + (cond + ((eq type-sym :macro) exp) + ((detect-infix exp) (parse-infix exp)) + (t (if-match (@(require (@x @y . @rest) + (and (not (fboundp x)) (fboundp y)))) + exp + ^(,y ,x ,*rest) + exp)))) (defmacro usr:ifx (. body) ^(expander-let ((*expand-hook* [expand-hook-combine infix-expand-hook |