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

;;; Reason: Warn when testing truth of a structure slot declared to be of a type that 
;;; can't ever be NIL.  [SPR 10472]

;;;                           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 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for COMPILER version 6.13
;;; Written 10/13/89 16:30:10 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With SYSTEM 6.20, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.4, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.4, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.12, TV 6.15, DATALINK 6.0, CHAOSNET 6.1, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.7,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.0, MAIL-DAEMON 6.3, MAIL-READER 6.5, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.3, PROFILE 6.2, Inconsistent TI-CLOS 6.26, CLEH 6.5, IP 3.54,
;;;  Experimental CLX 6.5, CLUE 6.25, X11M 6.15, Experimental BUG 11.15, Experimental DOCUMENTER 701.0,
;;;  Experimental SHRINK-TOOLS 6.1,  microcode 430, Band Name: 6.0+Scribe,&c,u430 9/6


;;; BUG REPORT NUMBER:  10472
;;;
;;; PROBLEM:  It is common for users to incorrectly define a structure like this:
;;;		(DEFSTRUCT CACHE-ENTRY
;;;	  	  ...
;;;	  	  (EA NIL :TYPE FIXNUM) ...)
;;;	and then try to do something like
;;;		(IF (CACHE-ENTRY-EA NEW-CACHE-ENTRY) ...)
;;;	where the compiler will optimize out the IF by considering that the 
;;;	condition is always true since the slot was declared to be a FIXNUM.
;;;
;;; SOLUTION:  This patch causes the compiler to warn when folding a condition 
;;;	that tests the value returned by a DEFSTRUCT accessor for a slot declared 
;;;	to be of a type that can't ever be NIL.
;;;
;;;	See also System patch 6.18, which modifies DEFSTRUCT to issue a warning for 
;;;	an obvious mismatch between a slot's initial value and type declaration.


#!C
; From file P1STYLE.LISP#> COMPILER; Hotel:
#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; P1STYLE.#"


(DEFUN AND-OR-STYLE (FORM)
  ;;  1/26/87 DNG - Original.
  ;;  2/05/87 DNG - Use a different message when type inferred from DEFCONSTANT instead of type declaration.
  ;;  2/06/87 DNG - Warn on AND and OR only when P1VALUE is D-INDS.
  ;;  7/06/87 DNG - Fix to avoid entering the error handler on an ill-formed COND. [SPR 5080]
  ;;  4/26/89 DNG - Don't pass NIL to TYPE-OF-EXPRESSION.
  ;; 10/13/89 DNG - Add checking for DEFSTRUCT accessors.  [SPR 10472]
  (LET ((FIRST-ARG-ONLY (NOT (MEMBER (FIRST FORM) '(AND OR COND XOR) :TEST #'EQ))))
    (UNLESS (OR FIRST-ARG-ONLY
		(EQ (FIRST FORM) 'COND)
		(EQ P1VALUE 'D-INDS))
      (RETURN-FROM AND-OR-STYLE))
    (DOLIST (ARG (CDR FORM))
     (BLOCK CHECK-ARG
      (WHEN (EQ (FIRST FORM) 'COND)
	(IF (CONSP ARG)
	    (SETQ ARG (FIRST ARG))
	  ;; Not legal, but P1COND will give a warning; don't trap here.
	  (RETURN-FROM CHECK-ARG)))
      (IF (AND (SYMBOLP ARG) (NOT (NULL ARG)))
	(LET* ((VAR (LOOKUP-VAR ARG VARS))
	       (DECLARED-TYPE (IF VAR
				  (VAR-DATA-TYPE VAR)
				(TYPE-OF-EXPRESSION ARG))))
	  (UNLESS (OR (EQ DECLARED-TYPE 'T)
		      (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE))
		      (AND (> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)
			      (OPT-SAFETY OPTIMIZE-SWITCH))
			   (RETURN-FROM AND-OR-STYLE))
		      (NOT (SI:DISJOINT-TYPEP DECLARED-TYPE 'NULL)))
	    (LET (( SI:WARNINGS-PRINLEVEL 2 ))
	      (WARN 'AND-OR-STYLE ':IMPLAUSIBLE
		    (IF (CONSTANTP ARG)
			"~S is a ~S constant so in ~S it is assumed never NIL."
		      "Variable ~S was declared ~S so in ~S it is assumed never NIL.")
		    ARG DECLARED-TYPE FORM)))
	  )
	;; Look for calls to DEFSTRUCT accessors.  Slot type declarations produce a 
	;; THE form in the expansion of the accessor DEFSUBST.
	(WHEN (AND (CONSP ARG)
		   (CDR ARG)
		   (NULL (CDDR ARG))
		   (SYMBOLP (FIRST ARG))
		   (FBOUNDP (FIRST ARG)))
	  (LET ((DEF (DECLARED-DEFINITION (FIRST ARG)))
		IDEF LAST)
	    (WHEN (AND (OR (SYS:COMPILED-SUBST? DEF)
			   (AND (CONSP DEF) (MEMBER (CAR DEF) SYS:*SUBST-LAMBDAS* :TEST #'EQ)))
		       (CONSP (SETQ IDEF (INTERPRETED-DEF DEF)))
		       (EQ (CAR-SAFE (SETQ LAST (CAR (LAST IDEF)))) 'THE))
	      (LET ((DECLARED-TYPE (SECOND LAST)))
		(UNLESS (OR (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE))
			    (AND (> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)
				    (OPT-SAFETY OPTIMIZE-SWITCH))
				 ;; DISJOINT-TYPEP is slow.
				 (RETURN-FROM AND-OR-STYLE))
			    (NOT (SI:DISJOINT-TYPEP DECLARED-TYPE 'NULL)))
		  (LET (( SI:WARNINGS-PRINLEVEL 2 ))
		    (WARN 'AND-OR-STYLE ':IMPLAUSIBLE
			  "Accessor ~S returns a slot declared to be of type ~S, so in
  ~S it is assumed never NIL."
			  (FIRST ARG) DECLARED-TYPE FORM)) )))))
	))
      (WHEN FIRST-ARG-ONLY (RETURN))
      ))
  NIL)

))