diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-15 17:33:53 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-15 17:33:53 -0800 |
| commit | 650635fb44133d97aa4f7b4b547796e29bbc7b96 (patch) | |
| tree | 1abcc07f18284d948256a6642c6f3cb62b803e10 | |
| parent | eb11c7d3acb1b37decf10455115440ff31881243 (diff) | |
| download | txr-650635fb44133d97aa4f7b4b547796e29bbc7b96.tar.gz txr-650635fb44133d97aa4f7b4b547796e29bbc7b96.tar.bz2 txr-650635fb44133d97aa4f7b4b547796e29bbc7b96.zip | |
matcher: remove useless code from @(some ...)
* share/txr/stdlib/match.tl (compile-loop-match): Eliminate
repeated (op eq 'some) tests by evaluating this once into the
some-p variable. Do not wastefully generate the code that
pushes values onto accumulation lists if we are translating
the some operator; those lists are ignored. Don't generate
those accumulation variables themselves at all.
| -rw-r--r-- | share/txr/stdlib/match.tl | 19 |
1 files changed, 11 insertions, 8 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index f86acb09..914e5ae2 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -164,6 +164,7 @@ (defun compile-loop-match (exp obj-var) (tree-bind (op match) exp (let* ((list-test (if (eq op 'usr:all*) 'consp 'listp)) + (some-p (eq op 'some)) (item-var (gensym "item-")) (cm (compile-match match item-var)) (loop-success-p-var (gensym "loop-success-p-")) @@ -174,25 +175,27 @@ (loop ^(for ((,iter-var ,obj-var) (,loop-continue-p-var t)) ((and ,loop-continue-p-var ,iter-var) - ,(if (eq op 'some) + ,(if some-p ^(not ,loop-continue-p-var) loop-continue-p-var)) ((set ,iter-var (cdr ,iter-var))) (let ((,cm.obj-var (car ,iter-var)) ,matched-p-var - ,*(if (eq op 'some) cm.(get-temps) cm.(get-vars))) + ,*(if some-p cm.(get-temps) cm.(get-vars))) ,cm.(wrap-guards ^(progn ,*cm.(assignments) (if ,cm.test-expr (progn (set ,matched-p-var t) - ,*(mapcar (ret ^(push ,@1 ,@2)) - cm.vars - collect-vars))))) - (,(if (eq op 'some) 'when 'unless) ,matched-p-var + ,*(unless some-p + (mapcar (ret ^(push ,@1 ,@2)) + cm.vars + collect-vars)))))) + (,(if some-p 'when 'unless) ,matched-p-var (set ,loop-continue-p-var nil))))) (guard (new match-guard - vars (cons loop-success-p-var collect-vars) + vars (cons loop-success-p-var (unless some-p + collect-vars)) var-exprs (list loop) guard-expr ^(,list-test ,obj-var)))) (new compiled-match @@ -201,7 +204,7 @@ guard-chain (list guard) test-expr loop-success-p-var vars cm.vars - var-exprs (unless (eq op 'some) + var-exprs (unless some-p (mapcar (ret ^(nreverse ,@1)) collect-vars)))))) (defun compile-or-match (or-pat obj-var) |