Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv6583

Modified Files: compiler.lisp Log Message: Make code-uses-binding-p not barf on certain labels forms.

--- /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/15 00:21:38 1.195 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/03/16 22:27:54 1.196 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.195 2008/03/15 00:21:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.196 2008/03/16 22:27:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -3160,16 +3160,37 @@

(defun code-uses-binding-p (code binding &key (load t) store call) "Does extended <code> potentially read/write/call <binding>?" - (labels ((search-funobj (funobj binding load store call) + (labels ((search-funobj (funobj binding load store call path) ;; If this is a recursive lexical call (i.e. labels), ;; the function-envs might not be bound, but then this ;; code is searched already. - (when (slot-boundp funobj 'function-envs) - (some (lambda (function-env-spec) - (code-search (extended-code (cdr function-env-spec)) binding - load store call)) - (function-envs funobj)))) - (code-search (code binding load store call) + (if (member funobj path) + nil + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + #+ignore + (if (member funobj path) + nil + (let* ((memo (assoc funobj memos)) + (x (cdr (or memo + (car (push (cons funobj + (when (slot-boundp funobj 'function-envs) + (some (lambda (function-env-spec) + (or (not (slot-boundp (cdr function-env-spec) 'extended-code)) ; Don't know yet, assume yes. + (code-search (extended-code (cdr function-env-spec)) + binding + load store call + (cons funobj path)))) + (function-envs funobj)))) + memos)))))) + (warn "search ~S ~S: ~S" funobj binding x) + x))) + (code-search (code binding load store call path) (dolist (instruction code) (when (consp instruction) (let ((x (or (when load @@ -3183,7 +3204,9 @@ (case (car instruction) (:local-function-init (search-funobj (function-binding-funobj (second instruction)) - binding load store call)) + binding + load store call + path)) (:load-lambda (or (when load (binding-eql binding (second instruction))) @@ -3193,16 +3216,22 @@ (typep allocation 'with-dynamic-extent-scope-env)) (binding-eql binding (base-binding allocation)))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call))) + binding + load store call + path))) (:call-lexical (or (when call (binding-eql binding (second instruction))) (search-funobj (function-binding-funobj (second instruction)) - binding load store call)))) + binding + load store call + path)))) (code-search (instruction-sub-program instruction) - binding load store call)))) + binding + load store call + path)))) (when x (return t))))))) - (code-search code binding load store call))) + (code-search code binding load store call nil)))

(defun bindingp (x) (typep x 'binding))