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

;;; Reason: Fix compiler to accept using LABELS to define local SETF functions.

;;;                           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 REL6G version 6.4
;;; Written 04/25/89 15:23:57 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent REL6G 6.3, Experimental 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, Experimental 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, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Experimental CLX 4.0, Experimental X11M 2.0, Experimental CLUE 19.1,
;;;  Experimental RPC 6.0, NFS 3.5, Experimental BUG 11.4, IP 3.43, Experimental DOCUMENTER 617.0,
;;;  Experimental TI-CLOS 17.0,  microcode 424, Band Name: REL6G,Scribe,&c u424 4/20

#!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 %LABELS P1) (FORM)
  ;;  3/06/86 - Allow declarations at the beginning of the body.
  ;;  6/21/86 - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.
  ;;  8/13/86 - Use SETQ instead of PSETQ in the expansion; store the BREAKOFF-FUNCTION
  ;;		or LEXICAL-CLOSURE form in the VARS table entry.
  ;;  9/11/86 - Modify to permit warnings on unused local functions.
  ;; 10/18/86 - Permit tail recursion elimination of local functions.
  ;;  2/13/87 - Update COMPILAND-INITIAL-ENVIRONMENT-VARS .
  ;; 10/26/88 DNG - Preserve CDDR of *LOCAL-ENVIRONMENT*.
  ;;  4/20/89 DNG - Include actual definition in *LOCAL-ENVIRONMENT* instead of 
  ;;		NIL; this is to avoid confusion with an undefined function in places 
  ;;		like TICLOS:FREEZE .
  ;;  4/24/89 DNG - Fix for non-symbol function specs.
  (LET ((LOCAL-FUNCTIONS
	  (NCONC (MAPCAR #'(LAMBDA (ELT)
			     (LIST (FIRST ELT) ; function name
				   (LOOKUP-VAR (SECOND ELT) VARS)
				   (THIRD ELT))) ; definition
			 (SECOND FORM))
		 LOCAL-FUNCTIONS))
	(*LOCAL-ENVIRONMENT*
	  ;; Defining a local function hides any local macro definition of same symbol.
	  (LIST* (FIRST *LOCAL-ENVIRONMENT*)
		 (CONS (LOOP FOR ELT IN (SECOND FORM)
			     NCONC (AND (SYMBOLP (FIRST ELT))
					(LIST* (LOCF (SYMBOL-FUNCTION (FIRST ELT))) (THIRD ELT) NIL)))
		       (SECOND *LOCAL-ENVIRONMENT*))
		 (CDDR *LOCAL-ENVIRONMENT*))))
    (LET ((P1VALUE 'DOWNWARD-ONLY))
      (DOLIST (ELT (SECOND FORM)) ; for each local function being defined
	(LET ((VALUE (P1 `(FLET-FUNCTION ,(THIRD ELT)))) ; the function object
	      (VAR (FIRST (FOURTH ELT))) ; the local variable which holds the function
	      (INIT (SECOND (FOURTH ELT)))) ; the dummy initial value to be replaced
	  (SETF (CAR INIT) (CAR VALUE))
	  (SETF (CDR INIT) (CDR VALUE))
	  ;; Since the dummy initial value was a constant, the variable was marked
	  ;; eligible for value propagation.  However, that is not appropriate if
	  ;; the function is a closure.
	  (UNLESS (EQ (CAR VALUE) 'BREAKOFF-FUNCTION)
	    (SETQ PROPAGATE-VAR-SET
		  (LOGDIF PROPAGATE-VAR-SET
			  (CDDR (VAR-LAP-ADDRESS (LOOKUP-VAR VAR))))))
	  (UNLESS (OR (= 0 LEXICAL-CLOSURE-COUNT)
		      (NOT (COMPILING-FOR-V2)))
	    ;; Once the first lexical lexical closure has been created, the environment
	    ;; has been constructed and we can't add any more copied-out values to it.
	    (DO ((VS (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*) (CDR VS)))
		((NULL VS))
	      (WHEN (EQ (VAR-NAME (CAR VS)) VAR)
		(SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*)
		      (CDR VS))
		(RETURN))))
	  )))
    (P1PROGN (CONS 'LOCALLY (CDDR FORM)))))

))