;;; -*- Mode:Common-Lisp; Package:SYSTEM; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB) -*- ;;; Reason: Modify DEFSTRUCT to warn if a slot's initial value is in obvious conflict with ;;; the slot's :TYPE option. Also, in such a case, don't make the type ;;; declaration available to the compiler for use in optimization. [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. ;;; Written 10/03/89 09:20:43 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With SYSTEM 6.17, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.2, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.3, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; Inconsistent COMPILER 6.12, TV 6.15, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, ;;; NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ;;; ZWEI 6.5, 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.1, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.4, Inconsistent TI-CLOS 6.24, CLEH 6.5, ;;; IP 3.50, Experimental CLX 6.3, CLUE 6.17, X11M 6.14, Experimental BUG 11.15, ;;; Experimental DOCUMENTER 701.0, 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 modifies DEFSTRUCT to check whether there is an ;;; obvious mismatch between a slot's initial value and type declaration. If ;;; so, a warning is issued, and the type is not used in the accessor, thus ;;; making it not available to the compiler for optimization. This is similar ;;; to the checking already performed for DEFCLASS slots in ;;; (:METHOD CLOS:STANDARD-CLASS :MAKE-SLOT-DESCRIPTION). ;;; ;;; This is not a complete solution, since the compiler should also warn when ;;; folding a condition based on a type declaration that can't ever be NIL, ;;; but that needs a separate patch to the compiler. ;;; ;;; DEPENDENCIES: [none] ;;; ;;; CODEREAD: C.L.M. #!C ; From file STRUCTURE.LISP#> KERNEL; Hotel: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; STRUCTURE.#" ;;;PHD 3/6/87 Fixed read-only slots. ;;;clm for DNG 03/06/89 Avoid generating a THE using the argument name in the type. [SPR 9150] 1;; DNG 10/3/89 Warn and don't use the slot type if it conflicts with the initial value. [SPR 10472]* (defun make-callable-accessors () (using-defstruct-special-variables) ;; first get the accessor code (let ((code (defstruct-type-description-accessor-code type-description)) (n-args (defstruct-type-description-ref-no-args type-description)) arglist junkpart) ;; come up with the arglist (setf junkpart (if (> n-args 1) (mapcar #'(lambda (x) x (gentemp)) (make-list (1- n-args))) ())) (setf arglist `(,@junkpart ,@(if default-pointer `(&optional (,name ,default-pointer)) `(,name)))) (dolist (slot slot-alist) (let* ((doc (defstruct-slot-description-documentation (rest slot))) (n (defstruct-slot-description-number (rest slot))) (ref (apply code n (append (if but-first `((,but-first ,name)) (list name)) junkpart))) (ppss (defstruct-slot-description-ppss (rest slot))) (accessor (if conc-name (create-symbol conc-name (first slot)) (first slot)))) ;; store accessor name in the slot-alist (setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor) ;; Check if it conflicts with a included one: (unless (or (defstruct-slot-description-name-slot-p (rest slot)) ;;don't create accessors for name-slots. (and include (eq accessor (defstruct-slot-description-ref-macro-name (cdr (assoc (car slot) (defstruct-description-slot-alist (get-defstruct-description (car include))) :test #'eq)))))) ;; store accessor name in the slot-alist (setf (defstruct-slot-description-ref-macro-name (rest slot)) accessor) ;;; phd 11/20/85 clears the setf method property (progn (push `(eval-when (compile) (putdecl ',accessor () 'setf-method)) returns) (push `(eval-when (load eval) (remprop ',accessor 'setf-method)) returns)) (if (defstruct-slot-description-read-only (rest slot)) (defstruct-putprop-compile-time accessor #'read-only-slot-setf-method 'setf-method)) (push `(defsubst ,accessor ,arglist ,@(if doc `(,doc) ()) ,function-parent-declaration ,(if (null ppss) (let ((slot-type (defstruct-slot-description-type (rest slot)))) (if (or (emptyp slot-type) 1(eq slot-type 't)* 1 (let ((initform (defstruct-slot-description-init-code (rest slot))))* 1(when (and (constantp initform)* 1(type-specifier-p slot-type nil)* 1(ignore-errors* 1; TYPE-SPECIFIER-P can't always be trusted - SPR 10678* 1(not (typep (eval initform) slot-type))))* 1 (non-fatal-error* 1 ':ignorable-mistake* 1 "The init form for slot ~S is ~S which is inconsistent with its type declaration of ~S."* 1 (car slot) initform slot-type)* 1 ;; Discard the type so that the compiler won't do optimizations* 1 ;; based on a type declaration that is obviously not valid.* 1 t))* (eq slot-type name) ; SUBST-EXPAND would replace the type with the argument name. (and (consp slot-type) (member name slot-type :test #'eq))) ref `(the ,slot-type ,ref))) `(ldb ,ppss ,ref))) returns)))) returns)) ))