diff options
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 35 |
1 files changed, 35 insertions, 0 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index fa209a4b..d406c6bc 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1159,12 +1159,18 @@ ((or (eql-comparable a) (eql-comparable b)) (set form ^(eql ,a ,b))))) + ((@(or append cons list list*) . @args) + (set form (reduce-lisp form))) ((@(@bin [%bin-op% @sym]) @a @b) (set form ^(,bin ,a ,b))) ((- @a) (set form ^(neg ,a))) ((@(or identity + * min max) @a) (return-from comp-fun-form me.(compile oreg env a)))) + + (when (or (atom form) (special-operator-p (car form))) + (return-from comp-fun-form me.(compile oreg env form))) + (tree-bind (sym . args) form (let* ((fbind env.(lookup-fun sym t)) (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall) @@ -1457,6 +1463,35 @@ (defun simplify-or (form) (reduce-or (flatten-or form))) +(defun reduce-lisp (form) + (let (oform) + (while* (nequal oform form) + (set oform form + form (match-case form + ((append (list . @largs) . @aargs) + ^(list* ,*largs (append ,*aargs))) + ((append @arg) arg) + (@(require (list* . @(listp @args)) + (equal '(nil) (last args))) + ^(list ,*(butlastn 1 args))) + (@(with (list* . @(listp @args)) + ((@(and @op @(or list list*)) . @largs)) (last args)) + ^(,op ,*(butlast args) ,*largs)) + (@(with (list* . @(listp @args)) + ((append . @aargs)) (last args)) + ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs)))) + ((@(or append list list*)) nil) + ((cons @a @b) + (let* ((lstar ^(list* ,a ,b)) + (rstar (reduce-lisp lstar))) + (if (eq lstar rstar) form rstar))) + ((cons @a (cons @b @c)) + ^(list* ,a ,b ,c)) + ((cons @a (@(and @op @(or list list*)) . @args)) + ^(,op ,a ,*args)) + (@else else)))) + form)) + (defun expand-quasi-mods (obj mods : form) (let (plist num sep rng-ix scalar-ix-p flex gens) (flet ((get-sym (exp) |