;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:8; Patch-file:T; Fonts:(CPTFONT CPTFONTB) -*- ;;; Reason: Fix XLD files in the USER package that reference symbols inherited from the ;;; TICLOS package to be loadable on earlier releases. [SPR 9955] ;;; Copyright (C) 1989 Texas Instruments Incorporated. All rights reserved. ;;; Patch file for COMPILER version 6.4 ;;; Written 06/15/89 18:54:33 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, ;;; Inconsistent COMPILER 6.3, 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 9955 ;; Problem ;; Backward compatibility problem. If, in a function, a reference is ;; made from within the USER package to a symbol which resides in the ;; TICLOS package (such as 'CLASS) the compiled code contains a ;; reference to 'TICLOS:CLASS, which when loaded on a pre 6.0 system ;; results in a error of package TICLOS not found. This is a side ;; effect of the USER package inheriting from TICLOS on 6.0. ;; ;; Note that this can (and did) happen when recompiling old code that doesn't ;; even use CLOS. ;; ;; Solution ;; When writing an XLD file, in COMPILER::PACKAGE-PREFIX-TO-DUMP, if ;; the current package is the USER package, and the symbol's home ;; package is TICLOS, then dump it using USER as the package prefix instead of ;; TICLOS. ;; Note: the second function below is not modified, it just needs to be ;; recompiled with the modified DEFSUBST. #!C ; From file FASD.LISP#> COMPILER; MR-X: #8R 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; FASD.#" 1;; 6/15/89 DNG - Add special handler for TICLOS symbols when the current package is USER. [SPR 9955]* ;;; This DEFSUBST is used only in FASD-SYMBOL. (DEFSUBST PACKAGE-PREFIX-TO-DUMP (SYMBOL &OPTIONAL (PKG *PACKAGE*)) (LET ((SYM-PKG (SYMBOL-PACKAGE SYMBOL))) (IF (COMPILING-FOR-V2) #+Elroy ;; Native compilation from VM2 (COND ((NULL SYM-PKG) (VALUES NIL T)) ((EQ SYM-PKG PKG-KEYWORD-PACKAGE) (VALUES "" NIL)) ((EQ SYM-PKG SI:PKG-LISP-PACKAGE) (VALUES 'LISP NIL)) ((EQ PKG SYM-PKG) NIL) ; ((AND PKG ; (MULTIPLE-VALUE-BIND (FOUNDSYM FOUNDP ACTUAL-PACKAGE) ; (FIND-SYMBOL SYMBOL PKG) ; ;; SYMBOL is interned in a package ; (AND FOUNDP ; (EQ FOUNDSYM SYMBOL) ; (MEMBER ACTUAL-PACKAGE (PACKAGE-USE-LIST PKG) :TEST #'EQ)))) ; NIL) 1 ((AND (EQ SYM-PKG '#,(FIND-PACKAGE :TICLOS))* 1(EQ PKG *USER-PACKAGE*)* 1(EQ SYMBOL (FIND-SYMBOL (SYMBOL-NAME SYMBOL) PKG) ))* 1 ;; For backward compatibility of files compiled on release 6 and loaded on * 1 ;; an earlier release, any symbols inherited by the USER package from * 1 ;; TICLOS are dumped without a prefix. This will still resolve to the * 1 ;; right symbol when loading on release 6 and will not get an undefined * 1 ;; package error on earlier releases. [SPR 9955]* 1 NIL)* (T ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well). ;; Dump it with a prefix. Note that even external symbols in used packages are dumped this way. (VALUES SYM-PKG T))) #-Elroy ;; Cross-compilation from VM1 (COND ((NULL SYM-PKG) (VALUES NIL T)) ((EQ SYM-PKG PKG-KEYWORD-PACKAGE) (VALUES "" NIL)) (T ;; Determine where the VM1 symbol lives in VM2. (let ((package-prefix-string-or-nil (MAPSYM symbol))) (COND ((STRINGP package-prefix-string-or-nil) (IF (string= package-prefix-string-or-nil "LISP") (VALUES 'LISP nil) ;FASD-SYMBOL treats LISP specially, so return a symbol as first value. (VALUES package-prefix-string-or-nil t))) ;; Else package-prefix-string-or-nil is NIL, meaning SYMBOL is not in a major package in VM2. ((EQ pkg sym-pkg) nil) ;No prefix needed here, since SYMBOL is interned in PKG (and nowhere else). (T ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well). ;; Dump it with a prefix. Note that even external symbols in used packages are dumped this way. (VALUES SYM-PKG T)))))) ;; Native compilation from VM1 (COND ((NULL SYM-PKG) (VALUES NIL T)) ((EQ SYM-PKG PKG-KEYWORD-PACKAGE) (VALUES "" NIL)) ((EQ PKG SYM-PKG) NIL) ; ((AND PKG ; (MULTIPLE-VALUE-BIND (FOUNDSYM FOUNDP ACTUAL-PACKAGE) ; (FIND-SYMBOL SYMBOL PKG) ; (AND FOUNDP ; (EQ FOUNDSYM SYMBOL) ; (MEMBER ACTUAL-PACKAGE (PACKAGE-USE-LIST PKG) :TEST #'EQ)))) ; NIL) (T ;; SYMBOL is interned in a package other than PKG (and possibly PKG as well). ;; Dump it with a prefix. Note that even external symbols in used packages are dumped this way. (VALUES SYM-PKG T)))))) (DEFUN FASD-SYMBOL (SYM &AUX (STARTED-FLAG NIL)) (MULTIPLE-VALUE-BIND (PKG-OR-STRING SHARP-FLAG) (PACKAGE-PREFIX-TO-DUMP SYM FASD-PACKAGE) ;; Here if symbol should print with a prefix of any kind - dump FASL-OP-PACKAGE-SYMBOL ;; For uninterned symbols, FASL-OP-PACKAGE-SYMBOL is also dumped so loader won't intern them (Release 3) (IF (COMPILING-FOR-V2) (PROGN (WHEN SHARP-FLAG (SETQ STARTED-FLAG T) (FASD-START-GROUP SHARP-FLAG 1 FASL-OP-PACKAGE-SYMBOL) (IF PKG-OR-STRING (PROGN (FASD-NIBBLE ;Always dump 2 since no local nicknames in VM2 packages - jk 2) (FASD-CONSTANT (IF (STRINGP PKG-OR-STRING) PKG-OR-STRING (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING)))) ;Dump package prefix (PROGN (FASD-NIBBLE 2) (FASD-CONSTANT "")))) ;Dump "" for uninterned symbol (IF STARTED-FLAG (FASD-CONSTANT (STRING SYM)) ;If there was a prefix (FASD-WRITE-STRING SYM (COND ((EQUAL PKG-OR-STRING "") FASL-OP-KEYWORD-SYMBOL);Handle KEYWORD package specially for speed ((EQ PKG-OR-STRING 'LISP) FASL-OP-LISP-SYMBOL) ;Handle LISP package specially for speed (T FASL-OP-SYMBOL))))) ;If no prefix is needed (PROGN (WHEN PKG-OR-STRING ;; Here if need a prefix of any kind. (SETQ STARTED-FLAG T) (FASD-START-GROUP SHARP-FLAG 1 FASL-OP-PACKAGE-SYMBOL) ;; This nibble is 402 if should ignore local nicknames, else 2. (FASD-NIBBLE (IF (AND (NOT (STRINGP PKG-OR-STRING)) (ASSOC (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING) (DONT-OPTIMIZE (SI:PKG-REFNAME-ALIST *PACKAGE*)) :TEST #'EQUAL)) #o402 2)) (FASD-CONSTANT (IF (STRINGP PKG-OR-STRING) PKG-OR-STRING (PACKAGE-PREFIX-PRINT-NAME PKG-OR-STRING)))) (IF STARTED-FLAG (FASD-CONSTANT (STRING SYM)) ;If there was a prefix (FASD-WRITE-STRING SYM FASL-OP-SYMBOL)))))) ;If no prefix is needed ))