;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Patch-file:T -*- ;;; Reason: Fix an error when evaluating a DEFCLASS with slot :TYPE options that refer to ;;; the class being defined. [SPR 9940] ;;; Copyright (C) 1989 Texas Instruments Incorporated. All rights reserved. ;;; Written 06/15/89 18:23:42 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With SYSTEM 6.6, VIRTUAL-MEMORY 6.1, EH 6.2, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.2, TV 6.8, DATALINK 6.0, CHAOSNET 6.0, GC 6.2, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.2, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.2, ;;; Inconsistent DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, TI-CLOS 6.5, CLEH 6.4, IP 3.46, ;;; Experimental BUG 11.8, Experimental CLX 6.1, CLUE 6.5, X11M 6.1, Experimental DOCUMENTER 6.0, ;;; microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8 ;; SPR Number 9940 ;; Problem ;; Compiler goes into the debugger when evaluating in a buffer a DEFCLASS with ;; slots having a :TYPE option that refers back to the class being defined. ;; ;; Solution ;; Fix function COMPILER:CANONICALIZE-TYPE-FOR-COMPILER to check for ;; (NULL *CURRENT-COMPILAND*) before testing ;; (COMPILAND-SUBST-FLAG *CURRENT-COMPILAND*) so that it doesn't blow up when ;; invoked from the DEFCLASS slot processing. #!C ; From file TYPEOPT.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; TYPEOPT.#" (DEFUN CANONICALIZE-TYPE-FOR-COMPILER ( TYPE &OPTIONAL CONTEXT VALUES-PERMITTED-P ) ;; 8/29/86 DNG - Original. ;; 10/07/86 DNG - New optional arg VALUES-PERMITTED-P. ;; 2/11/87 DNG - For a valid type that is not a subtype of any INTERESTING-TYPES, ;; return T instead of the canonicalized type since it is not of any ;; use for optimization but might lead to trouble when checking initial ;; values against their type declarations. ;; 7/08/87 DNG - Fix to accept FUNCTION types. [SPR 5777] ;; 9/29/87 DNG - Fix for FUNCTION in OR types. [SPR 6572] ;; 1/16/88 DNG - Add handling for name defined by DEFTYPE to be a FUNCTION ;; type. [SPR 6977] Permit returning (FUNCTION ...) type list since ;; EXPR-TYPE-P can now handle it. ;; 4/07/88 DNG - Use GETDECL instead of GET. [SPR 7746] ;; 8/15/88 DNG - Return CLOS class names instead of T. ;; 10/25/88 DNG - Reference BUILT-IN-CLASS instead of STANDARD-TYPE-CLASS. ;; 12/19/88 DNG - Suppress warning on undefined types in a DEFSUBST. [SPR 9150] ;; 4/25/89 DNG - Permit returning a class object. ;; 6/15/89 DNG - Make sure *CURRENT-COMPILAND* is not NIL before testing ;; COMPILAND-SUBST-FLAG. [SPR 9940] (MULTIPLE-VALUE-BIND (USABLEP LEGALP) (TYPE-SPECIFIER-P TYPE *COMPILE-FILE-ENVIRONMENT*) (COND (USABLEP ; fully defined (IF (AND (SYMBOLP TYPE) (MEMBER TYPE INTERESTING-TYPES :TEST #'EQ)) TYPE (LET ((CANONIZED (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*))) (DOLIST (X INTERESTING-TYPES) (WHEN (SUBTYPEP CANONIZED X *COMPILE-FILE-ENVIRONMENT*) (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER (IF (AND (MEMBER X '(ARRAY VECTOR)) (CONSP CANONIZED) (NOT (MEMBER (SECOND CANONIZED) '(T * NIL)))) (LIST* (FIRST CANONIZED) (CANONICALIZE-TYPE-FOR-COMPILER (SECOND CANONIZED) TYPE) (CDDR CANONIZED)) X)))) (LET ((CLASS (IF (SYS:CLASSP TYPE) TYPE (AND (SYMBOLP TYPE) (FBOUNDP 'TICLOS:CLASS-NAMED) (TICLOS:CLASS-NAMED TYPE T *COMPILE-FILE-ENVIRONMENT*))))) (COND ((NULL CLASS) T) ((TYPEP-STRUCTURE-OR-FLAVOR CLASS 'TICLOS:BUILT-IN-CLASS) T) (T CLASS)))))) ((AND (CONSP TYPE) (EQ (CAR TYPE) 'VALUES) VALUES-PERMITTED-P) (IF (= (LENGTH TYPE) 2) (CANONICALIZE-TYPE-FOR-COMPILER (SECOND TYPE) CONTEXT NIL) (CONS 'VALUES (LOOP FOR ITEM IN (CDR TYPE) IF (MEMBER ITEM '(&OPTIONAL &REST &KEY)) ;; legal but not worth bothering with DO (RETURN-FROM CANONICALIZE-TYPE-FOR-COMPILER 'UNKNOWN) ELSE COLLECT (CANONICALIZE-TYPE-FOR-COMPILER ITEM CONTEXT NIL))))) ((EQ TYPE 'FUNCTION) ;; Legal for declarations even though TYPEP doesn't currently accept it [ref SPR 5778]. T) ; not currently interesting. ((AND (CONSP TYPE) (EQ (FIRST TYPE) 'FUNCTION) (= (LENGTH TYPE) 3) (LISTP (SECOND TYPE))) ;; Legal for declarations even though TYPEP doesn't accept it. (LIST (FIRST TYPE) (LET ((KEY NIL)) (LOOP FOR ITEM IN (SECOND TYPE) ; argument types COLLECT (COND ((MEMBER ITEM LAMBDA-LIST-KEYWORDS :TEST #'EQ) (WHEN (EQ ITEM '&KEY) (SETQ KEY T)) ITEM) ((AND KEY (LISTP ITEM) (SYMBOLP (FIRST ITEM))) (LIST (FIRST ITEM) (CANONICALIZE-TYPE-FOR-COMPILER (SECOND ITEM) TYPE))) (T (CANONICALIZE-TYPE-FOR-COMPILER ITEM TYPE))))) (CANONICALIZE-TYPE-FOR-COMPILER (THIRD TYPE) TYPE T) ; result type )) (LEGALP ;; Here for a SATISFIES type that uses a predicate that isn't defined yet. ;; The compiler doesn't have any use for SATISFIES types anyway. T) ((AND (SYMBOLP TYPE) (GETDECL TYPE 'SI:TYPE-EXPANDER NIL *COMPILE-FILE-ENVIRONMENT*)) ;; Here for a name defined by DEFTYPE to be a FUNCTION type. [SPR 6977] (CANONICALIZE-TYPE-FOR-COMPILER (TYPE-CANONICALIZE TYPE *COMPILE-FILE-ENVIRONMENT*) CONTEXT VALUES-PERMITTED-P)) ((AND (MEMBER (CAR-SAFE TYPE) '(OR AND) :TEST #'EQ) (CONSP (CDR TYPE))) ;; If one of the elements of the OR is a FUNCTION type, TYPE-SPECIFIER-P ;; will have rejected it, but we still need to allow it. [SPR 6572] (LET ((UNION NIL)) (DOLIST (X (REST TYPE)) (LET ((CANONIZED (CANONICALIZE-TYPE-FOR-COMPILER X TYPE VALUES-PERMITTED-P))) (COND ((SUBTYPEP CANONIZED UNION *COMPILE-FILE-ENVIRONMENT*)) ((SUBTYPEP UNION CANONIZED *COMPILE-FILE-ENVIRONMENT*) (SETQ UNION CANONIZED)) (T (SETQ UNION T)) ))) UNION)) (T ;; Permit forward type references in a DEFSUBST since the type may be known when it is expanded. (unless (and (symbolp type) ;; Could be NIL when invoked from ;; (:METHOD CLOS:STANDARD-CLASS :MAKE-SLOT-DESCRIPTION) ;; Should permit forward references there anyway. (or (null *current-compiland*) (compiland-subst-flag *current-compiland*))) (WARN 'CANONICALIZE-TYPE-FOR-COMPILER ':IGNORABLE-MISTAKE (IF (OR (SYMBOLP TYPE) (AND (CONSP TYPE) (SYMBOLP (FIRST TYPE)) (NEQ (FIRST TYPE) 'QUOTE) )) "Undefined type specifier ~S in ~S" "Invalid type specifier syntax ~S in ~S") TYPE CONTEXT)) (IF (SYMBOLP TYPE) TYPE 'UNKNOWN))))) ))