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

;;; Reason: Added copy-list to  p1progn-1. [10822]

;;;                           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/30/90 12:39:39 by BERGER,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.35, VIRTUAL-MEMORY 6.3, EH 6.8, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.5, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.8, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.13, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.14, TV 6.25, DATALINK 6.0, CHAOSNET 6.8, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.3,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.2, ZWEI 6.18,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.3, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.6, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.5, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.47, CLEH 6.5, IP 3.65,
;;;  Experimental CLX 6.11, CLUE 6.104, X11M 6.24, Experimental BUG 11.19,  microcode 483,
;;;  Band Name: REL 6.0 +SLE 5/30

#!C
; From file P1HAND.LISP#> COMPILER; SYS:
#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 P1PROGN-1 ( FORMS )
  ;; Apply P1 to a list of forms where only the last form is
  ;;  evaluated for its result value.
  ;; 08/27/84 DNG - Redesigned to discard dead code following an
  ;;	       unconditonal transfer of control.
  ;; 12/28/84 DNG - Discard constant and variable arguments whose
  ;;	       value is not going to be used.
  ;; 10/20/86 DNG - Return ('NIL) instead of an empty list so that EXPR-TYPE-P
  ;;		can meaningfully look at the last argument of a LET.
  ;; 11/17/88 DNG - Optimize nested PROGNs.
  (OR (LET* ( ( DEST P1VALUE ) ( P1VALUE NIL )
	     ( FORMS-LEFT FORMS ) BEFORE AFTER
	     (BODY
	       (LOOP UNTIL (NULL FORMS-LEFT)
		     DO (PROGN (SETQ BEFORE (CAR FORMS-LEFT))
			       (SETQ FORMS-LEFT (CDR FORMS-LEFT))
			       (WHEN (NULL FORMS-LEFT)
				 (SETQ P1VALUE DEST) )
			       (SETQ AFTER (P1 BEFORE)) )
		     WHEN (OR P1VALUE (NOT (NO-SIDE-EFFECTS-P AFTER)))
		     COLLECTING AFTER
		     ELSE DO (DISCARD AFTER)
		     UNTIL (AND (CONSP AFTER)
				(MEMBER (FIRST AFTER) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ) 
				(PROG1 T (P1-DEAD-FORMS FORMS-LEFT) ) ))))
	(WHEN (EQ (CAR-SAFE (FIRST BODY)) 'PROGN)
	  ;; optimize (PROGN (PROGN a b) x y) ==> (PROGN a b x y)
	  ;; This doesn't help by itself but may enable other optimizations.
	  (SETQ BODY (NCONC (REST (FIRST BODY)) (REST BODY))))
	BODY)
      (copy-list '((QUOTE NIL)))  ; DAB 05-30-90 Return a new list each time, otherwise list grows. 
      ))
))