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

;;; Reason: Update the compiler to accept DEFAULT-TYPE declarations used by TICLOS:PARSE-METHOD.

;;;                           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.14
;;; Written 05/08/89 22:40:36 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent REL6H 6.13, 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.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 619.0,  microcode 426, Band Name: Rel6H,Scribe,
;;; &c, u426 5/4

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


(DEFUN PROCESS-PERVASIVE-DECLARATIONS (DECLS &OPTIONAL LOCAL-DECLS EXPR-DEBUG-INFO JUNK-ALLOWED-P)
  ;; This function handles any pervasive declarations appearing within a
  ;; function being compiled.  Declarations which affect variable
  ;; binding are processed in P1SBIND and are ignored here.
  ;; Top-level declarations are handled separately by functions
  ;; DECLARE and PROCLAIM.
  ;; 8/13/84 DNG - Removed (PUSHNEW VARNAME FREEVARS) since it will be
  ;;		done by P1 for any special variables which are actually
  ;;		referenced.  This avoids allocating space in the FEF for
  ;;		pointers to the value cells of variables declared
  ;;		SPECIAL but never actually referenced.
  ;; 9/06/84 DNG - Changed function name from PROCESS-SPECIAL-DECLARATIONS.
  ;; 9/11/84 DNG - Add error check for :SELF-FLAVOR declarations.
  ;;12/07/84 DNG - Allow SELF-FLAVOR without colon.
  ;; 1/18/85 DNG - Fix message to say DECLARATION instead of DECLARATIONS;
  ;;		   check SI:INTERPRETER-DECLARATION-TYPE-ALIST.
  ;; 2/20/85 DNG - Suppress :SELF-REF error message in a certain case.
  ;; 3/09/85 DNG - Disallow :SELF-REF declaration within a binding of SELF.
  ;; 1/23/86 DNG - Obsolete warning on keyword declaration names.
  ;; 6/18/86 DNG - Major changes to handling of debug-info declarations.  Push
  ;;		on LOCAL-DECLARATIONS only what is needed there.  Avoid processing
  ;;		top-level declarations twice.
  ;; 6/20/86 DNG - Add JUNK-ALLOWED-P option.
  ;; 7/02/86 DNG - Fix to allow :INTERNAL function to have :SELF-FLAVOR different from parent.
  ;; 7/10/86 DNG - Fix the JUNK-ALLOWED-P option.
  ;; 7/17/86 DNG - Add SYS:DOWNWARD-FUNCTION declaration.
  ;; 8/26/86 DNG - Add handling for FTYPE and FUNCTION declarations [previously ignored].
  ;; 9/02/86 DNG - SI:INTERPRETER-DECLARATION-TYPE-ALIST no longer used in release 3.
  ;;10/01/86 DNG - Add special warning for RETURN-LIST.
  ;;10/11/86 DNG - Permit :EXPR-SXHASH declaration.
  ;;10/17/86 DNG - Warn on non-symbol in SPECIAL declaration.
  ;;11/14/86 DNG - Fix to allow an UNSPECIAL declaration to shadow a previous SPECIAL declaration.
  ;; 5/23/88 DNG - Add support for TICLOS::SPECIALIZERS declarations.
  ;; 4/06/89 DNG - Recognize ARGLIST declaration in any package and accept the 
  ;;		Lucid syntax as well as the LispM syntax.
  ;; 4/25/89 DNG - Minor fixes for SELF-FLAVOR and DOWNWARD-FUNCTION criteria.
  ;; 4/28/89 DNG - Permit DEFAULT-TYPE.
  (DECLARE (ARGLIST THIS-FRAME-DECLARATIONS &OPTIONAL OLD-LOCAL-DECLARATIONS OLD-EXPR-DEBUG-INFO)
	   (VALUES NEW-LOCAL-DECLARATIONS NEW-EXPR-DEBUG-INFO))
  (DOLIST (DECL DECLS)
    (IF (OR (ATOM DECL) (NOT (SYMBOLP (FIRST DECL))))
	(WARN 'PROCESS-PERVASIVE-DECLARATIONS ':IMPOSSIBLE
	      "Invalid declaration syntax: (DECLARE ~S)" DECL)
      (LET (( DT (FIRST DECL) ) DSTRING )
	(DECLARE (SYMBOL DT))
	(BLOCK WARNING
	  (COND
	    ( (MEMBER DT '( TYPE IGNORE .ARG. SI:DOWNWARD-FUNARG DEFAULT-TYPE ) :TEST #'EQ)
	     ;; Ignore these here.  They are handled by function
	     ;;   PROCESS-BINDING-DECLARATIONS which is called by P1SBIND.
	     ;; [SYS:DOWNWARD-FUNARG is for brand S compatibility.]
	     )
	    ( (MEMBER DT '(INLINE NOTINLINE TRY-INLINE) :TEST #'EQ)
	     (DOLIST ( FN (REST DECL))
	       (IF (SI:VALIDATE-FUNCTION-SPEC FN)
		   (PUSH (CONS (IF (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)
				   (LIST ':INTERNAL
					 (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)
					 FN)
				 FN)
			       DT)
			 INLINE-DECLARATIONS)
		 (WARN 'SI:VALIDATE-FUNCTION-SPEC ':IGNORABLE-MISTAKE
		       "Invalid function spec ~S in ~S declaration."
		       FN DT) )))

	    ( (EQ DT 'OPTIMIZE)
	     (DECLARE-OPTIMIZE (REST DECL)) )

	    ( (EQ DT '.AUX.)
	     ;; duplicate declarations created by P1AUX for P1SBIND; ignore here.
	     (RETURN) )

	    ( (MEMBER DT '( FTYPE FUNCTION ) :TEST #'EQ)
	     (SETQ LOCAL-DECLS (DECLARE-FTYPE DECL LOCAL-FUNCTIONS LOCAL-DECLS)) )

	    ((MEMBER DT *LOCAL-DECLARATIONS-SPECIFIERS* :TEST #'EQ)
	     (COND ((MEMBER DT '(SPECIAL :SPECIAL) :TEST #'EQ) 
		    (DOLIST (VARNAME (CDR DECL))
		      (IF (SYMBOLP VARNAME)
			  (PUSH (MAKE-FREE-VAR-HOME VARNAME) VARS)
			(WARN 'SPECIAL :IMPOSSIBLE
			      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL)
			)))
		   ((MEMBER DT '(UNSPECIAL :UNSPECIAL) :TEST #'EQ) 
		    (DOLIST (VARNAME (CDR DECL))
		      (IF (SYMBOLP VARNAME)
			  (LET ((SPECIAL NIL))
			    (DOLIST (V VARS)
			      (WHEN (EQ VARNAME (VAR-NAME V))
				(COND ((EQ (VAR-TYPE V) 'FEF-SPECIAL)
				       (SETQ SPECIAL V))
				      (SPECIAL
				       (PUSH V VARS)
				       (RETURN))
				      (T (RETURN))))))
			(WARN 'SPECIAL :IMPOSSIBLE
			      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL)
			))))
	     ;; Push these on LOCAL-DECLARATIONS for future reference.
	     ;;   SPECIAL and UNSPECIAL are noticed in FIND-TYPE;
	     ;;	  DEF is used by SYS:DECLARED-DEFINITION in file MINDEFS.
	     (PUSH DECL LOCAL-DECLS) )

	    ((STRING-EQUAL (SETQ DSTRING (STRING DT)) "SELF-FLAVOR")
	     (COND ((AND (OR (NULL SELF-FLAVOR-DECLARATION) ; not already declared
			     ;; The following test is to permit an :INTERNAL function to
			     ;; have a different flavor from its parent.
			     (AND (ZEROP EXPRESSION-SIZE) (NULL ALLVARS)
				  (EQ SELF-FLAVOR-DECLARATION (COMPILAND-FLAVOR *CURRENT-COMPILAND*))))
			 (NOT (LOOKUP-VAR 'SELF ALLVARS)))
		    ;; We can make this function into a method for the indicated
		    ;; flavor providing that SELF has been set up before the
		    ;; function is entered so that the microcode can get the
		    ;; right mapping table at function entry.
		    (SETF SELF-FLAVOR-DECLARATION (REST DECL))
		    (WHEN (AND SELF-FLAVOR-DECLARATION
			       ;; If the user just did (declare (:self-flavor flname)),
			       ;; compute the full declaration for that flavor.
			       (NULL (CDR SELF-FLAVOR-DECLARATION)))
		      (SETF SELF-FLAVOR-DECLARATION
			    (CDR (SI:FLAVOR-DECLARATION (CAR SELF-FLAVOR-DECLARATION)))) ))
		   ((INCLUDED-FLAVOR-P (SECOND DECL) (CAR SELF-FLAVOR-DECLARATION))
		    ;; Redundant declaration, ignore.
		    )
		   (T (WARN ':SELF-FLAVOR ':IMPOSSIBLE
			    "In a method for flavor ~S, there is a :SELF-FLAVOR declaration for
flavor ~S, which is not included in ~S."
			    (CAR SELF-FLAVOR-DECLARATION) (SECOND DECL)
			    (CAR SELF-FLAVOR-DECLARATION) ) ) )
	     (RETURN-FROM WARNING) )

	    ( (EQ DT 'SI:DOWNWARD-FUNCTION) ; for brand S compatibility
	     (WHEN (AND (ZEROP EXPRESSION-SIZE) ; at beginning of function
			(>= (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)))
	       (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'SI:DOWNWARD-FUNCTION)
		     T))) ; used by BREAKOFF

	    ( (ASSOC DT SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES* :TEST #'EQ)
	     ;; These declarations have no effect other than to be copied into
	     ;; the function's debugging info.  They are significant only at the
	     ;; top level of the function.
	     (PUSH DECL EXPR-DEBUG-INFO) )

	    ( (EQ DT ':EXPR-SXHASH)
	     (PUSH (IF (COMPILING-FOR-V2) (CONS DT (SECOND DECL)) DECL)
		   EXPR-DEBUG-INFO)
	     (RETURN-FROM WARNING) )

	    ( (STANDARD-TYPE-NAME-P DT T)
	     ;; The name of a standard type; ignore here since this is
	     ;;	  handled in PROCESS-BINDING-DECLARATIONS .
	     )

	    ( (EQ DT 'TICLOS::SPECIALIZERS)
	     (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) DT) (REST DECL)))

	    ((STRING-EQUAL DSTRING "ARGLIST") ; permit in any package
	     (PUSH (CONS 'ARGLIST (IF (AND (NULL (CDDR DECL))
					   (LISTP (SECOND DECL))) ; looks like Lucid style
				      (SECOND DECL)
				    (CDR DECL) ; else assume LispM style
				    ))
		   EXPR-DEBUG-INFO))

	    ( (MEMBER DT DECLARATIONS-IGNORED :TEST #'EQ)
	     (RETURN-FROM WARNING) )

	    ( (MEMBER DT '(SI:ARRAY-REGISTER SI:ARRAY-REGISTER-1D) 
		      :TEST #'EQ)
	     ;; ignored for brand S compatibility
	     (RETURN-FROM WARNING) )

	    ((STRING-EQUAL DSTRING "RETURN-LIST") ; now in ZLC package
	     (WARN 'RETURN-LIST ':IGNORABLE-MISTAKE
		   "(DECLARE ~S) doesn't work anymore, use (DECLARE (VALUES ...))"
		   DECL)
	     (RETURN-FROM WARNING))
	    
	    ( JUNK-ALLOWED-P
	     ;; At top level, LOCAL-DECLARATIONS may contain things other than
	     ;; valid declaration specifiers.  Just pass them through in same order.
	     (SETQ LOCAL-DECLS (NCONC LOCAL-DECLS (CONS DECL NIL))) )

	    ( T (WARN 'PROCESS-PERVASIVE-DECLARATIONS ':PROBABLE-ERROR
		      "Unrecognized declaration: (DECLARE ~S)
If you want it allowed and ignored, do (PROCLAIM '(DECLARATION ~S))" DECL DT)
		(RETURN-FROM WARNING) )
	    )				   ; end of COND
	  (WHEN (AND COMPILING-COMMON-LISP
		     (NOT INHIBIT-STYLE-WARNINGS-SWITCH)
		     (KEYWORDP DT))
	    (WARN ':DECLARE ':OBSOLETE
		  "(DECLARE (~S ...)) is obsolete; use (DECLARE (~A ...))."
		  DT DT) )
	  ) ; end of BLOCK WARNING
	))) ; end of DOLIST
  (VALUES LOCAL-DECLS EXPR-DEBUG-INFO) )
))