;;; -*- Mode: Common-Lisp; Package: SYS; Base: 8.; Patch-File: T -*-

;;; Reason: Fixed print-pname-string to print a colon for keywords when *package* is bound to the KEYWORD package. [10335]

;;;                           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 SYSTEM version 6.25
;;; Written 11/22/89 07:40:56 by BERGER,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.23, 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.6, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, 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.8,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, 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.1, MAIL-DAEMON 6.3, MAIL-READER 6.6, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.56,
;;;  Experimental CLX 6.7, CLUE 6.32, X11M 6.16, Experimental BUG 11.17, DECNET 1.70,
;;;   microcode 429, Band Name: rel6.0 10/23

#!C
; From file PRINT.LISP#> KERNEL; SYS:
#8R 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; PRINT.#"


(defun print-pname-string  (symbol stream fastp &optional no-package-prefixes &aux
			    (character-attribute-table (character-attribute-table *readtable*)))
  ;;CLM for PHD 10/20/87 print-package according to *print-case* and slashification
  (declare (ignore fastp))
  (when (symbolp symbol)
    (let ((sym-pkg (symbol-package symbol))
	  (pname   (symbol-name symbol)))
      (when (and *print-escape* (not no-package-prefixes))
	(cond 
	      ((null sym-pkg)
	       (when *print-gensym*
		 (send stream :string-out (pttbl-uninterned-symbol-prefix *readtable*))))
	      ;;DAB 11-22-89 Switch the next two clauses so that 
	      ;;symbols in the KEYWORD package will print with a colon even
	      ;;if *PACKAGE* is bound to the KEYWORD package, as specified on   [10335]
	      ((eq sym-pkg *keyword-package*)
	       (send stream :string-out (pttbl-package-prefix *readtable*)))
	      ((eq sym-pkg *package*))
	      
	      (t
	       ;; At this point, we know the symbol is interned and
	       ;;that it is interned in some package other than *package*.
	       ;; If the symbol is inherited, no prefix will be necessary.
	       (multiple-value-bind (sym flag)
		   (and *package* (find-symbol pname *package*))
		 (if (and flag (eq sym symbol))
		     ;; inherited
		     (when (assoc symbol *reader-symbol-substitutions* :test #'eq)
		       ;; There  is a substitution going on at reading time that shadows the symbol,
		       ;; So we have to print the package prefix to force the reading.
		       (send stream :string-out (package-prefix-print-name sym-pkg))
		       (send stream :string-out
			     (if (eq flag :internal)
				 (pttbl-package-internal-prefix *readtable*)
				 (pttbl-package-prefix *readtable*))))
		     ;; Else symbol is not inherited [it could be shadowed]. Print prefix
		     ;; and use either ":" or "::" accordingly as external or internal.
		     (unless (and sym (eq sym (car (rassoc symbol *reader-symbol-substitutions* :test #'eq))))
		       ;;If the symbol is shadowing an accessible symbol because of *reader-symbol-substitutions*
		       ;;then we don't need to print the prefix.
		       ;;If the symbol is shadowing another one, then it does not need any package prefix.
		       (multiple-value-bind (fsym flag-1)
			   (find-symbol pname sym-pkg)  ;; <fsym> is eq to <symbol> so we ignore it
			 (declare (ignore fsym))
			 (output-case-symbol (package-prefix-print-name sym-pkg) stream)
			 (send stream :string-out
			       (if (eq flag-1 :internal)
				   (pttbl-package-internal-prefix *readtable*)
				   (pttbl-package-prefix *readtable*))))))))))
      (output-case-symbol pname stream))))
))