diff options
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 52 |
1 files changed, 27 insertions, 25 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 1ab48537..fe796218 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1686,29 +1686,31 @@ (defun reduce-lisp (form) (fixed-point equal form - (match-case form - ((append (list . @largs) . @aargs) - ^(list* ,*largs (append ,*aargs))) - ((@(or append list*) @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)))) + (rlcp + (match-case form + ((append (list . @largs) . @aargs) + ^(list* ,*largs (append ,*aargs))) + ((@(or append list*) @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 reduce-constant (env form) (if (consp form) @@ -1717,8 +1719,8 @@ (not env.(lookup-fun op))) (let ((cargs [mapcar (op reduce-constant env) args])) (if [all cargs constantp] - ^(quote ,(eval ^(,op ,*cargs))) - ^(,op ,*cargs))) + ^(quote ,(eval (rlcp ^(,op ,*cargs) form))) + (rlcp ^(,op ,*cargs) form))) form)) form)) |