;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T -*-

;;; Reason: Fix compiler bookkeeping bug on SETQ in a TAGBODY in a DEFMETHOD [problem 
;;; introduced by patch 6.12].

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for REL6H version 6.17
;;; Written 05/18/89 13:44:29 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent REL6H 6.16, SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0, Experimental EH 6.0,
;;;  Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0, Experimental LOCAL-FILE 6.0,
;;;  Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0, Experimental BASIC-NAMESPACE 6.0,
;;;  Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0, Experimental DISK-LABEL 6.0,
;;;  Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0, Experimental NETWORK-PATHNAME 6.0,
;;;  Experimental COMPILER 6.0, TV 6.0, Experimental DATALINK 6.0, Experimental CHAOSNET 6.0,
;;;  Experimental GC 6.0, Experimental MEMORY-AUX 6.0, Experimental NVRAM 6.0, Experimental SYSLOG 6.0,
;;;  Experimental STREAMER-TAPE 6.0, Experimental CLEH 1.0, Experimental UCL 6.0,
;;;  Experimental INPUT-EDITOR 6.0, Experimental METER 6.0, Experimental ZWEI 6.0,
;;;  Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0, Experimental NETWORK-SERVICE 6.0,
;;;  DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0, Experimental SERIAL 6.0,
;;;  Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0, Experimental PRINTER-TYPES 6.0,
;;;  Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0, Experimental MAIL-DAEMON 6.0,
;;;  Experimental MAIL-READER 6.0, Experimental TELNET 6.0, Experimental VT100 6.0,
;;;  Experimental NAMESPACE-EDITOR 6.0, PROFILE 6.0, VISIDOC 6.0, Experimental TI-CLOS 17.6,
;;;  Experimental CLX 5.0, Experimental CLUE 20.0, Experimental X11M 3.0, Experimental RPC 6.0,
;;;  Experimental NFS 6.0, Experimental BUG 11.4, IP 3.45, Experimental DOCUMENTER 618.0,
;;;   microcode 426, Band Name: Rel6H,Scribe,&c, u426 5/4

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN UPDATE-PROPAGATE-VAR-SET ()
  ;; Stop propagation of initial values for any variables which were
  ;;  modified within a TAGBODY or loop.
  ;; 1/24/85 - Original version.
  ;; 5/03/89 DNG - Use MAYBE-PROPAGATE to reconfirm variables affected by SETQ-OPT.
  ;; 5/18/89 DNG - Fix for when *LOOP-VAR-BIT* is zero.
  (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET ALTERED-VAR-SET))
  ;; Need to make sure that SETQ-OPT has not changed the initial value form to 
  ;; something that is not eligible for propagation.  Only need to check 
  ;; variables bound within the innermost loop.
  (MAP-VARIABLES-IN-SET
     #'(LAMBDA (V BIT)
	  ;; Reconfirm its eligibility for propagation.
	  (UNLESS (MAYBE-PROPAGATE V)
	     ;; Nope; remove it from the set.
	     (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET BIT))))
     (IF (> *LOOP-VAR-BIT* 0)
	 (LOGDIF PROPAGATE-VAR-SET (- *LOOP-VAR-BIT* 1))
       PROPAGATE-VAR-SET)
     VARS)
  (LET (( STOP-SUBST-SET (LOGAND SUBST-VAR-SET ALTERED-VAR-SET) )
	INIT LAPAD )
    (UNLESS (ZEROP STOP-SUBST-SET)
      ;; The code in the TAGBODY has modified one or more variables
      ;; which were used as initial values of other variables; must
      ;; stop doing propagation for those values.
      (DOLIST ( V VARS )
	(WHEN (AND (CONSP (SETQ INIT (VAR-INIT-FORM V)))
		   (EQ (CAR INIT) 'LOCAL-REF)
		   (LOGTEST STOP-SUBST-SET (CDDR INIT))
		   (CONSP (SETQ LAPAD (VAR-LAP-ADDRESS V)))
		   (EQ (CAR LAPAD) 'LOCAL-REF))
	  (SETQ PROPAGATE-VAR-SET
		(LOGDIF PROPAGATE-VAR-SET (CDDR LAPAD)))
	  (WHEN (ZEROP PROPAGATE-VAR-SET) (RETURN))
	  ))
      (SETQ SUBST-VAR-SET (LOGDIF SUBST-VAR-SET STOP-SUBST-SET)) ) )
  )

))