From d8f7c3255a287fab054c6d0407f84b817c978b64 Mon Sep 17 00:00:00 2001 From: Roman Marynchak Date: Thu, 24 Mar 2011 18:51:43 +0200 Subject: [PATCH] Simplify LOOP-HACK-ITERATION * Collect the repeated code patterns into a macro. * Get rid of the optional handler's arguments, because they are absent in LOOP-DO-FOR (and there are no other iteration handlers at this time). --- src/code/loop.lisp | 101 ++++++++++++++++++++++++++------------------------- 1 files changed, 51 insertions(+), 50 deletions(-) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 969475a..204bfa4 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -834,7 +834,8 @@ code to be loaded. ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) - (loop-hack-iteration tem)) + ;; Iteration keywords handlers do not have arguments, so ignore REST. + (loop-hack-iteration (symbol-function (first tem)))) ((loop-tmember keyword '(and else)) ;; The alternative is to ignore it, i.e. let it go ;; around to the next keyword... @@ -1319,7 +1320,7 @@ code to be loaded. ;;;; the iteration driver -(defun loop-hack-iteration (entry) +(defun loop-hack-iteration (handler) (flet ((make-endtest (list-of-forms) (cond ((null list-of-forms) nil) ((member t list-of-forms) '(go end-loop)) @@ -1328,54 +1329,54 @@ code to be loaded. (car list-of-forms) (cons 'or list-of-forms)) (go end-loop)))))) - (do ((pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data)) - (nil) - ;; Note that we collect endtests in reverse order, but steps in correct - ;; order. MAKE-ENDTEST does the nreverse for us. - (setq tem (setq data - (apply (symbol-function (first entry)) (rest entry)))) - (and (car tem) (push (car tem) pre-step-tests)) - (setq steps (nconc steps (copy-list (car (setq tem (cdr tem)))))) - (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) - (setq pseudo-steps - (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) - (setq tem (cdr tem)) - (when *loop-emitted-body* - (loop-error "iteration in LOOP follows body code")) - (unless tem (setq tem data)) - (when (car tem) (push (car tem) pre-loop-pre-step-tests)) - ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough - ;; that it might be worth making it into an NCONCF macro. - (setq pre-loop-steps - (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) - (when (car (setq tem (cdr tem))) - (push (car tem) pre-loop-post-step-tests)) - (setq pre-loop-pseudo-steps - (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) - (unless (loop-tequal (car *loop-source-code*) :and) - (setq *loop-before-loop* - (list* (loop-make-desetq pre-loop-pseudo-steps) - (make-endtest pre-loop-post-step-tests) - (loop-make-psetq pre-loop-steps) - (make-endtest pre-loop-pre-step-tests) - *loop-before-loop*)) - (setq *loop-after-body* - (list* (loop-make-desetq pseudo-steps) - (make-endtest post-step-tests) - (loop-make-psetq steps) - (make-endtest pre-step-tests) - *loop-after-body*)) - (loop-bind-block) - (return nil)) - (loop-pop-source)))) ; Flush the "AND". + (macrolet ((set-from-tem (dst) + `(setq ,dst (nconc ,dst (copy-list (car (setq tem (cdr tem)))))))) + (do ((pre-step-tests nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) + ;; Note that we collect endtests in reverse order, but steps in correct + ;; order. MAKE-ENDTEST does the nreverse for us. + (setq tem (setq data + (funcall handler))) + (and (car tem) (push (car tem) pre-step-tests)) + (set-from-tem steps) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (set-from-tem pseudo-steps) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "iteration in LOOP follows body code")) + (unless tem (setq tem data)) + (when (car tem) (push (car tem) pre-loop-pre-step-tests)) + ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough + ;; that it might be worth making it into an NCONCF macro. + (set-from-tem pre-loop-steps) + (when (car (setq tem (cdr tem))) + (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps + (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) + (unless (loop-tequal (car *loop-source-code*) :and) + (setq *loop-before-loop* + (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*)) + (setq *loop-after-body* + (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source))))) ; Flush the "AND". ;;;; main iteration drivers -- 1.6.3.3