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

;;; Reason: Fix compiler bug in propagation of SETQ values to not propagate values set in 
;;; the body of an UNWIND-PROTECT, CATCH, or BLOCK, since they could be exited 
;;; prematurely.

;;;                           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.

;;; Written 05/18/89 11:15:19 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Experimental REL6H 6.15, 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 (:PROPERTY UNWIND-PROTECT P1) (FORM)
  ;;  5/18/89 DNG - Original; created to bind *LOOP-VAR-BIT*.
  (LET ((*LOOP-VAR-BIT* VAR-BIT))
    (P1PROG1 FORM)))
))

#!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 P1CATCH (FORM)
  ;;  5/10/86 DNG - Original; replaces pre-optimizer *CATCH-PROGNIFY.
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.
  (LIST '*CATCH
	(P1V (SECOND FORM))
	(LET ((*LOOP-VAR-BIT* VAR-BIT))
	  (P1 (CONS 'PROGN (CDDR FORM))))))
))

#!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 P1BLOCK (FORM &OPTIONAL BIND-RETPROGDESC)
  ;;  7/10/86 DNG - Eliminated ENTRY-LEXICAL-CLOSURE-COUNT and PROGDESC-EXIT-LEXICAL-CLOSURE-COUNT
  ;;		fields from progdesc; include VARS and USED-BIT.
  ;;  9/10/86 DNG - Changed handling of non-local returns to fix SPR 505.
  ;; 10/11/86 DNG - Error message for block name not a symbol.
  ;; 10/18/86 DNG - PROGDESC-RETTAG now a structure instead of a symbol.
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.  The way it is done here is 
  ;;		actually over-kill; we would like to set it only when the first RETURN 
  ;;		is found, but that is a refinement that will have to wait for next release.
  (LET* ((PROGNAME (CADR FORM))
	 (BODY (CDDR FORM))
	 (RETTAG (GENSYM))
	 (TAG (MAKE-GOTAG RETTAG RETTAG))
	 (CATCH-TAG (AND (NOT INLINE-EXPANSIONS) ; breakoffs not allowed within procedure integration
			 (SYMBOLP PROGNAME)
			 (IF (NULL PROGNAME)
			     '|Exit block NIL|
			   (MAKE-SYMBOL (STRING-APPEND "Exit block " (STRING PROGNAME)) NIL))))
	 LOCAL-GOTAGS
	 (GOTAGS GOTAGS)
	 (TRE-OK TRE-OK)
	 (PROGDESC (MAKE-PROGDESC
		     NAME PROGNAME  RETTAG TAG
		     IDEST P1VALUE
		     VARS VARS
		     USED-BIT (PROG1 VAR-BIT
				     (SETQ VAR-BIT (ASH VAR-BIT 1)))
		     CATCH-TAG CATCH-TAG))
	 (PROGDESCS (CONS PROGDESC PROGDESCS))
	 (RETPROGDESC
	   (IF (OR (AND BIND-RETPROGDESC (NEQ PROGNAME T)) (NULL PROGNAME))
	       PROGDESC
	     RETPROGDESC))
	 (*LOOP-VAR-BIT* VAR-BIT))
    (SETF (GOTAG-PROGDESC TAG) PROGDESC)
    (UNLESS (OR (SYMBOLP PROGNAME)
		(AND (FIXNUMP PROGNAME) (NOT COMPILING-COMMON-LISP)))
      (WARN 'PROGNAME :IMPOSSIBLE "The BLOCK name ~S is not a symbol." PROGNAME))
    (WHEN (CDR BODY) (SETQ TLEVEL NIL))
    ;; Push on GOTAGS a description of this prog's "return tag",
    ;; a tag we generate and stick at the end of the prog.
    (PUSH TAG LOCAL-GOTAGS)
    (PUSH TAG GOTAGS)
    (IF (NULL CATCH-TAG) ; no possibility of a non-local return
	`(,(CAR FORM) ,LOCAL-GOTAGS ,PROGDESC . ,(P1PROGN-1 BODY))
      (P1 `(LET* ((,CATCH-TAG (UNDEFINED-VALUE)))
	     (%BLOCK-BODY ,(CAR FORM) ,LOCAL-GOTAGS ,PROGDESC . ,BODY))))
    ))

))

#!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 (:PROPERTY %DISPATCH P1) ( FORM )
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.
  (LET* (( SELECTOR (P1V (SECOND FORM)) )
	 ( MAX -1 )
	 ( DEFAULT (P1 (THIRD FORM)) )
	 ( BODY (LET (( P1VALUE NIL )
		      (*LOOP-VAR-BIT* *LOOP-VAR-BIT*))
		  (LOOP FOR X IN (NTHCDR 3 FORM)
			COLLECT (IF (FIXNUMP X)	   ; value tag
				    (PROGN (SETQ *LOOP-VAR-BIT* VAR-BIT)
					   (WHEN (> X MAX)
					     (SETQ MAX X) )
					   X )
				  ;; Else, form to be executed.
				  (P1 X) ) ) ) ))
    (IF (< MAX 0) ; if no tags
	`(PROGN ,SELECTOR ,DEFAULT)
      `(%DISPATCH ,SELECTOR
		  ,MAX			   ; maximum selector value
		  ,DEFAULT		   ; default action
		  . ,BODY) ) ))
))