Hack fix for shadowing problem

[Jeff Dalton <jeff@aiai.edinburgh.ac.uk>]

;;; Code to fix some bugs in KCL when loaded.

(in-package :kcl-bug-fixes)

;;; (SHADOW sym pack) doesn't put sym on pack's list of shadowing
;;; symbols if it is already interned in pack.  A USE-PACKAGE of a
;;; package that exports a symbol with the same name as sym will
;;; therefore still signal a name conflict (though it shouldn't).

;;; So, we put the symbol on the lists of shadowing symbols
;;; "by hand".  Since PACKAGE-SHADOWING-SYMBOLS isn't settable,
;;; we have to modify the list.  If the list is null, we have
;;; to make it non-null by making a useless symbol and shadowing
;;; it.

;;; Note that our version of SHADOW does not do anything special
;;; for strings that are given as names to shadow.

(defun new-shadow (symbols &optional (package *package*))
  (unless (listp symbols)
    (setq symbols (list symbols)))
  (unless (packagep package)
    (setq package (find-package package)))
  (dolist (sym symbols)
    (if (not (symbolp sym))
	(old-shadow sym package)
      (multiple-value-bind (found-sym status)
	  (find-symbol (symbol-name sym) package)
	(if (member status '(:internal external))
	    (progn (assert (eq sym found-sym))
		   (force-shadowing sym package))
	  (old-shadow sym package)))))
  t)

(defun force-shadowing (sym pack)
  (push sym (cdr (force-shadowing-list pack))))

(defun force-shadowing-list (pack)
  (or (package-shadowing-symbols pack)
      (progn (old-shadow (make-symbol "a symbol to be shadowed")
			 pack)
	     (package-shadowing-symbols pack))))

;;; Install the new definition when this file is loaded.

(eval-when (load eval)
  (unless (fboundp 'old-shadow)
    (setf (symbol-function 'old-shadow)
	  (symbol-function 'shadow))
    (setf (symbol-function 'shadow)
	  (symbol-function 'new-shadow))))

;;; End