(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")))
(il:filecreated "29-Sep-88 12:15:02" il:|{EG:PARC:XEROX}<LANNING>LISP>USERS>META-CALL-LABELS-PATCH.;1| 2943   

      il:|changes| il:|to:|  (il:vars il:meta-call-labels-patchcoms) (il:functions meta-call-labels)

      il:|previous| il:|date:| "28-Sep-88 19:40:11" 
il:{phylum}<lisp>medley>patches>meta-call-labels-patch.\;1)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:meta-call-labels-patchcoms)

(il:rpaqq il:meta-call-labels-patchcoms ((il:functions meta-call-labels) (il:prop il:makefile-environment il:meta-call-labels-patch)))

(defun meta-call-labels (node context) (il:* il:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them.") (let ((*made-changes* nil)) (il:* il:|;;| "First, substitute the functions wherever possible.") (dolist (fn-pair (labels-funs node) (when (null (node-meta-p (labels-body node))) (setf (node-meta-p node) nil) (setq *made-changes* t))) (when (substitutable-p (cdr fn-pair) (car fn-pair)) (let ((*subst-occurred* nil)) (il:* il:|;;| "First try substituting into the body.") (setf (labels-body node) (meta-substitute (cdr fn-pair) (car fn-pair) (labels-body node))) (when (not *subst-occurred*) (il:* il:|;;| "Wasn't in the body - try the other functions.") (dolist (target-pair (labels-funs node)) (unless (eq target-pair fn-pair) (setf (cdr target-pair) (meta-substitute (cdr fn-pair) (car fn-pair) (cdr target-pair))) (when *subst-occurred* (il:* il:\; "Found it, we can stop now.") (setf (node-meta-p node) nil) (setq *made-changes* t) (return))))) (il:* il:|;;| "May need to reanalyze the node, since things might have changed.  Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost.") (dolist (fns (labels-funs node)) (meval (cdr fns) :argument)) (meval (labels-body node) :return)))) (il:* il:|;;| "Now remove any functions that aren't referenced.") (dolist (fn-pair (prog1 (labels-funs node) (setf (labels-funs node) nil))) (cond ((null (variable-read-refs (car fn-pair))) (release-tree (cdr fn-pair)) (setq *made-changes* t)) (t (push fn-pair (labels-funs node))))) (il:* il:|;;| "If there aren't any functions left, replace the node with its body.") (when (null (labels-funs node)) (let ((body (labels-body node))) (setf (labels-body node) nil) (release-tree node) (setq node body *made-changes* t))) (il:* il:|;;| "Finally, set the meta-p flag if everythings OK.") (if (null *made-changes*) (setf (node-meta-p node) context) (setf (node-meta-p node) nil))) node)

(il:putprops il:meta-call-labels-patch il:makefile-environment (:readtable "XCL" :package (defpackage "COMPILER" (:use "LISP" "XCL"))))
(il:putprops il:meta-call-labels-patch il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop