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

;;; Reason: Fix bug in compilation of GENERIC-FLET, GENERIC-LABELS, etc.
;;; Suppress compiler warning about undefined function when it is defined as a 
;;; DEFCLASS accessor.

;;;                           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.4
;;; Written 05/02/89 21:10:55 by GRAY,
;;; while running on Kelvin from band LOD5
;;; With Experimental REL6H 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 TI-CLOS 17.1, 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 425, Band Name: Rel 6.0 + SLE 5/2

#!C
; From file CLOS.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; CLOS.#"



(DEFUN OPTIMIZE-LOCAL-GENERIC (THE-FORM)
  ;; Used by the pass 1 handlers for GENERIC-FLET and GENERIC-LABELS.
  ;; 11/17/88 DNG - Original.
  ;; 12/28/88 DNG - Fix to pass :GENERIC-FUNCTION-CLASS option to MAKE-GENERIC-FUNCTION.
  ;;  5/02/89 DNG - Update to check %LET instead of LET.
  (WHEN (EQ (FIRST THE-FORM) 'THE-EXPR)
    (LET (LET-FORM NEW-BODY (ADOPTED '()))
      (CASE (FIRST (EXPR-FORM THE-FORM))
	((%LET %LET*) (SETQ LET-FORM (EXPR-FORM THE-FORM))
		      (SETQ NEW-BODY (NTHCDR 2 LET-FORM)))
	(PROGN (SETQ NEW-BODY (CDR (EXPR-FORM THE-FORM)))))
      ;; Try to optimize creation of generic functions.
      (DOLIST (V (FIRST (SECOND LET-FORM)))
	(LET ((INIT-FORM (VAR-INIT-FORM V)))
	  (WHEN (AND (CONSP INIT-FORM)
		     (EQ (FIRST INIT-FORM) 'LEXICAL-CLOSURE)
		     (> (LENGTH INIT-FORM) 3))
	    (LET ((GFUN (FIFTH INIT-FORM)))
	      (comment ; not needed yet, may be useful for optimizing to call method directly.
		(SETF (GETF (VAR-DECLARATIONS V) ':GENERIC-FUNCTION)
		      GFUN))
	      (IF (THIRD INIT-FORM)
		  ;; Ephemeral local function, can construct generic function at load time.
		  (SETF (CAR INIT-FORM) (FOURTH INIT-FORM)
			(CDR INIT-FORM) (LIST (SECOND INIT-FORM) (THIRD INIT-FORM)))
		;; Else output code to construct the generic function at run time.
		(SETF (CAR INIT-FORM) 'TICLOS:MAKE-GENERIC-FUNCTION
		      (CDR INIT-FORM) (CONS (P1 ':GENERIC-FUNCTION-CLASS)
					    (CDR (P1V (SEND GFUN :FASD-FORM))))))))))
      ;; Try to optimize installation of methods.
      (DOLIST (BODY-FORM NEW-BODY)
	(LET (INIT-FORM)
	  (IF (AND (CONSP BODY-FORM)
		   (EQ (FIRST BODY-FORM) 'TICLOS:ADD-METHOD)
		   (PROGN (SETQ INIT-FORM (SECOND BODY-FORM))	; generic function
			  (WHEN (EQ (CAR-SAFE (SECOND BODY-FORM)) 'LOCAL-REF)
			    (SETQ INIT-FORM (VAR-INIT-FORM (SECOND INIT-FORM))))
			  (EQ (CAR-SAFE INIT-FORM) 'BREAKOFF-FUNCTION)))
	      ;; Adding method to a local generic function constructed at load time.
	      (LET ((MM (THIRD BODY-FORM)) ; MAKE-METHOD form
		    COMPILAND)
		(WHEN (AND (EQ (CAR-SAFE MM) 'TICLOS:MAKE-METHOD)
			   (EQ (CAR-SAFE (FOURTH MM)) 'BREAKOFF-FUNCTION)
			   (EQL 1 (COMPILAND-USE-COUNT (SETQ COMPILAND (SECOND (FOURTH MM))))))
		  ;; Add the method at load time instead of run time.
		  (LET* ((GCOMP (SECOND INIT-FORM))	; generic function compiland
			 (GNAME (COMPILAND-FUNCTION-SPEC GCOMP))	
			 (FSPEC `(TICLOS:METHOD ,GNAME ,@(SECOND (SECOND MM)) ,(SECOND (THIRD MM)))))
		    (SETF (EXPR-FORM THE-FORM) (DELETE BODY-FORM (THE LIST (EXPR-FORM THE-FORM))
						       :TEST #'EQ :COUNT 1))
		    (DISCARD BODY-FORM)
		    ;; Attach the method compiland to its generic function compiland;
		    ;; LAP-MFEF will put the methods on COMPILER-QUEUE after finishing 
		    ;; compilation of the generic function.
		    (PUSH COMPILAND (GETF (COMPILAND-PLIST GCOMP) 'INITIAL-METHODS))
		    ;; The name is modified destructively so that the change will also affect any children.
		    (SETF (CAR (COMPILAND-FUNCTION-SPEC COMPILAND)) (CAR FSPEC))
		    (SETF (CDR (COMPILAND-FUNCTION-SPEC COMPILAND)) (CDR FSPEC))
		    (SETF (CAR (COMPILAND-FUNCTION-NAME COMPILAND)) (CAR FSPEC))
		    (SETF (CDR (COMPILAND-FUNCTION-NAME COMPILAND)) (CDR FSPEC))
		    (PUSH COMPILAND ADOPTED)
		    )))
	    (RETURN))))
      ;; This is just to shorten the local FEF lists in the debug info.
      (DO ()
	  ((OR (NULL ADOPTED)
	       (NOT (EQ (CAR ADOPTED) (CAR (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))))
	(POP ADOPTED)
	(POP (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
	(POP (COMPILAND-LOCAL-FUNCTION-MAP *CURRENT-COMPILAND*)))
      ;; Now re-optimize the LET.
      (SETF (EXPR-FORM THE-FORM) (POST-OPTIMIZE (EXPR-FORM THE-FORM)))) )
  THE-FORM)

))

#!C
; From file FILE.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; FILE.#"


(ADD-OPTIMIZER TICLOS:MAKE-READER		NOTICE-FDEFINE) ; 5/2/89 DNG
(ADD-OPTIMIZER TICLOS:MAKE-WRITER		NOTICE-FDEFINE) ; 5/2/89 DNG

))