X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fiterate.lisp;h=ebfbf9859c08d07d973f6dba2277cf4bacc5f605;hb=986ce2596822cc0871b609346aaf592348aca596;hp=59dbbc87dfd06b875c6d3ce0aaa5e8a75521448e;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/iterate.lisp b/src/pcl/iterate.lisp index 59dbbc8..ebfbf98 100644 --- a/src/pcl/iterate.lisp +++ b/src/pcl/iterate.lisp @@ -1,6 +1,14 @@ ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. +;;;; FIXME: It'd be nice to get rid of all 750 lines of code in this +;;;; file, plus miscellaneous cruft elsewhere (e.g. the definition of +;;;; the SB-ITERATE package). There are only 20 calls to this ITERATE +;;;; macro in the PCL code. (There's another ITERATE macro used in the +;;;; classic CMU CL code, but that's different.) Most if not all of +;;;; them would be easy to replace with ANSI LOOP or simpler standard +;;;; iteration constructs. + ;;;; This software is derived from software originally released by Xerox ;;;; Corporation. Copyright and release statements follow. Later modifications ;;;; to the software are in the public domain and are provided with @@ -22,11 +30,9 @@ ;;;; specification. (in-package "SB-ITERATE") - -(sb-int:file-comment - "$Header$") -;;; Are warnings to be issued for iterate/gather forms that aren't optimized? +;;; Are warnings to be issued for iterate/gather forms that aren't +;;; optimized? ;;; NIL => never ;;; :USER => those resulting from user code ;;; T => always, even if it's the iteration macro that's suboptimal. @@ -36,46 +42,6 @@ (defmacro iterate (clauses &body body &environment env) (optimize-iterate-form clauses body env)) -(defun - simple-expand-iterate-form - (clauses body) - - ;; Expand ITERATE. This is the "formal semantics" expansion, which we never - ;; use. - (let* - ((block-name (gensym)) - (bound-var-lists (mapcar #'(lambda (clause) - (let ((names (first clause))) - (if (listp names) - names - (list names)))) - clauses)) - (generator-vars (mapcar #'(lambda (clause) - (declare (ignore clause)) - (gensym)) - clauses))) - `(block ,block-name - (let* - ,(mapcan #'(lambda (gvar clause var-list) - ;; For each clause, bind a generator temp to the clause, - ;; then bind the specified var(s). - (cons (list gvar (second clause)) - (copy-list var-list))) - generator-vars clauses bound-var-lists) - - ;; Note bug in formal semantics: there can be declarations in the head - ;; of BODY; they go here, rather than inside loop. - (loop - ,@(mapcar - #'(lambda (var-list gen-var) - ;; Set each bound variable (or set of vars) to the result of - ;; calling the corresponding generator. - `(multiple-value-setq ,var-list - (funcall ,gen-var #'(lambda nil (return-from - ,block-name))))) - bound-var-lists generator-vars) - ,@body))))) - ;;; temporary variable names used by ITERATE expansions (defparameter *iterate-temp-vars-list* '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 @@ -383,10 +349,12 @@ (parse-declarations let-body locals) (cond ((setq specials (extract-special-bindings locals localdecls)) - (maybe-warn (cond ((find-if #'variable-globally-special-p - specials) - ; This could be the fault of a - ; user proclamation. + (maybe-warn (cond ((find-if + #'var-globally-special-p + specials) + ;; This could be the + ;; fault of a user + ;; proclamation. :user) (t :definition)) @@ -444,61 +412,55 @@ ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we ;;; return the transformed body; on failure, :ABORT. - (walk-form let-body iterate-env - #'(lambda (form context env) - (declare (ignore context)) - - ;; Need to substitute RENAMED-VARS, as well as turn - ;; (FUNCALL finish-arg) into the finish form - (cond ((symbolp form) - (let (renaming) - (cond ((and (eq form finish-arg) - (variable-same-p form env - iterate-env)) - ; An occurrence of the finish - ; arg outside of FUNCALL - ; context--I can't handle this - (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." - (second clause)) - (return-from iterate-transform-body - :abort)) - ((and (setq renaming (assoc form - renamed-vars - )) - (variable-same-p form env - iterate-env)) - ; Reference to one of the vars - ; we're renaming - (cdr renaming)) - ((and (member form bound-vars) - (variable-same-p form env - iterate-env)) - ; FORM is a var that is bound - ; in this same ITERATE, or - ; bound later in this ITERATE*. - ; This is a conflict. - (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." - (second clause) - form) - (return-from iterate-transform-body - :abort)) - (t form)))) - ((and (consp form) - (eq (first form) - 'funcall) - (eq (second form) - finish-arg) - (variable-same-p (second form) - env iterate-env)) - ; (FUNCALL finish-arg) => - ; finish-form - (unless (null (cddr form)) - (maybe-warn :definition - "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." - (second clause) - (cddr form))) - finish-form) - (t form))))) + (walk-form + let-body + iterate-env + (lambda (form context env) + (declare (ignore context)) + + ;; We need to substitute RENAMED-VARS, as well as turn + ;; (FUNCALL finish-arg) into the finish form. + (cond ((symbolp form) + (let (renaming) + (cond ((and (eq form finish-arg) + (var-same-p form env iterate-env)) + ;; an occurrence of the finish arg outside + ;; of FUNCALL context: I can't handle this! + (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." + (second clause)) + (return-from iterate-transform-body + :abort)) + ((and (setq renaming (assoc form renamed-vars)) + (var-same-p form env iterate-env)) + ;; Reference to one of the vars + ;; we're renaming + (cdr renaming)) + ((and (member form bound-vars) + (var-same-p form env iterate-env)) + ;; FORM is a var that is bound in this same + ;; ITERATE, or bound later in this ITERATE*. + ;; This is a conflict. + (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." + (second clause) + form) + (return-from iterate-transform-body + :abort)) + (t form)))) + ((and (consp form) + (eq (first form) + 'funcall) + (eq (second form) + finish-arg) + (var-same-p (second form) env + iterate-env)) + ;; (FUNCALL finish-arg) => finish-form + (unless (null (cddr form)) + (maybe-warn :definition + "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." + (second clause) + (cddr form))) + finish-form) + (t form))))) (defun parse-declarations @@ -551,7 +513,7 @@ ;; Return the subset of VARS that are special, either globally or ;; because of a declaration in DECLS - (let ((specials (remove-if-not #'variable-globally-special-p vars))) + (let ((specials (remove-if-not #'var-globally-special-p vars))) (dolist (d decls) (when (eq (car d) 'special) @@ -648,7 +610,7 @@ (let (pair) (cond ((and (symbolp form) (setq pair (assoc form alist)) - (variable-same-p form subenv env)) + (var-same-p form subenv env)) (cdr pair)) (t form)))))) @@ -698,9 +660,9 @@ (t ; General case--I know nothing `(multiple-value-setq ,vars ,expr)))) -(defun variable-same-p (var env1 env2) - (eq (variable-lexical-p var env1) - (variable-lexical-p var env2))) +(defun var-same-p (var env1 env2) + (eq (var-lexical-p var env1) + (var-lexical-p var env2))) (defun maybe-warn (type &rest warn-args) @@ -1051,8 +1013,7 @@ (declare (ignore context)) (let (pair) (cond ((or (not (symbolp form)) - (not (variable-same-p form subenv - env))) + (not (var-same-p form subenv env))) ; non-variable or one that has ; been rebound form) @@ -1124,11 +1085,11 @@ ,(second form))) (t ; FN = (lambda (value) ...) (dolist (s (third info)) - (unless (or (variable-same-p s env - gathering-env) - (and (variable-special-p + (unless (or (var-same-p s env + gathering-env) + (and (var-special-p s env) - (variable-special-p + (var-special-p s gathering-env))) ;; Some var used free in the LAMBDA form has been @@ -1150,7 +1111,7 @@ (list fn (second form)))))) ((and (setq info (member site *active-gatherers*)) (or (eq site '*anonymous-gathering-site*) - (variable-same-p site env (fourth info)))) + (var-same-p site env (fourth info)))) ; Some other GATHERING will ; take care of this form, so ; pass it up for now. @@ -1175,7 +1136,7 @@ `(%orphaned-gather ,@(cdr form))))) ((and (symbolp form) (setq info (assoc form acc-info)) - (variable-same-p form env gathering-env)) + (var-same-p form env gathering-env)) ; A variable reference to a ; gather binding from ; environment TEM @@ -1240,10 +1201,10 @@ #'(lambda nil result)))) (defmacro summing (&key (initial-value 0)) - `(let ((sum ,initial-value)) - (values #'(lambda (value) - (setq sum (+ sum value))) - #'(lambda nil sum)))) + `(let ((sum ,initial-value)) + (values #'(lambda (value) + (setq sum (+ sum value))) + #'(lambda nil sum)))) ;;; It's easier to read expanded code if PROG1 gets left alone. (define-walker-template prog1 (nil return sb-walker::repeat (eval)))