;;; -*- Mode: Common-Lisp; Package: TICLOS; Base: 10.; Patch-File: T -*-

;;; Reason: Expanded the error message in ENSURE-GENERIC-FUNCTION to include the symbol's name and properties. Modified (standard-class :make-slot-description) to warn and then ignore slot accessor option that has a symbol-function value that is not a generic-function. [11055]

;;;                           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.

;;; Written 04/10/90 09:56:51 by BERGER,
;;; while running on Pasteur from band LOD2
;;; With SYSTEM 6.31, VIRTUAL-MEMORY 6.3, EH 6.6, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.4, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.10, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.1,
;;;  COMPILER 6.14, TV 6.24, DATALINK 6.0, CHAOSNET 6.6, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.13,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.4, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.7, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.7, TI-CLOS 6.43, CLEH 6.5, IP 3.60,
;;;  Experimental CLX 6.10, CLUE 6.88, X11M 6.21, Experimental BUG 11.19,  microcode 648,
;;;  Band Name: rel6.0 1/23

#!C
; From file META-OBJECT.LISP#> CLOS; SYS:
#10R TICLOS#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; META-OBJECT.#"


(defun ENSURE-GENERIC-FUNCTION (fspec &rest options
				   &key environment &allow-other-keys)
  "Define a generic function or update its options."
  (declare (arglist function-spec &key lambda-list argument-precedence-order
		    declare documentation generic-function-class
		    method-combination method-class environment))
  (let ((old-def (or (and (compiler:environment-remote-p environment)
			  (let ((compiler:*compile-file-environment*
				  (compiler:env-global-env environment)))
			    (compiler:file-local-def fspec)))
		     (sys:fdefinition-safe fspec t))))
    (unless (or (null old-def)
		(generic-function-p old-def))
      (let ((debug-st (si:get-debug-info-struct fspec)))
	(cerror "Discard the current definition of ~s and create a generic function."
		"~s is not a generic function. ~%The current definition of ~a is in the package ~a and defined in the file ~a.~% It has an  arglist of  ~a and a documentation string of ~s."
		fspec (si:get-debug-info-field debug-st :name)
		(symbol-package (si:get-debug-info-field debug-st :name))
		(get (si:get-debug-info-field debug-st :name) :source-file-name)
		(si:get-debug-info-field debug-st :arglist)
		(si:get-debug-info-field debug-st :documentation))
      )
      (setq old-def nil))
    (apply #'ensure-generic-function-using-class old-def fspec options)))
))


#!C
; From file class.LISP#> CLOS; SYS:
#10R TICLOS#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; class.#"




(defmethod (standard-class :make-slot-description) (slot  class-name)
  ;;  8/17/88 DNG - Added support for :DOCUMENTATION option. Default :TYPE to T.
  ;;  9/12/88 DNG - Fix initclosure optimization.
  ;;  9/21/88 DNG - Fix initclosure optimization for macro defined in same file.
  ;;		Record documentation in slot description.
  ;; 11/03/88 DNG - Add check for invalid slot name.
  ;; 11/17/88 DNG - Cleaned up handling of options.
  ;;  4/26/89 DNG - Add warning for misplaced option keyword.
  ;;  5/06/89 DNG - Add warnings for invalid type specifier and initform inconsistent with type.
  ;;  6/16/89 DNG - After warning that the :INITFORM and :TYPE options are 
  ;;		inconsistent, change the type to T so that the compiler won't do 
  ;;		optimizations based on a type declaration that is obviously wrong. [SPR 9800]
  (let (slot-name slot-options reader-list writer-list 
	reader writer accessor initform (initform-provided-p nil)
	(allocation :instance) (allocation-provided-p nil)
	(type t) (type-provided-p nil)
	initarg (initargs nil)
	documentation)
    (if (consp slot)
	(setf slot-name (car slot)
	      slot-options (rest slot))
	(progn (when (and compiler:qc-file-in-progress
			  (member slot '(:accessor :reader :writer :initarg :initform) :test #'eq))
		 ;; Probably missing a left parenthesis; a common mistake.
		 (compiler:warn 'make-slot-description ':implausible
				"Option keyword ~S found where a slot name or slot specifier list was expected.
Check your parentheses." slot))
	       (setf slot-name slot slot-options nil)))
    (unless (symbolp slot-name)
      (non-fatal-error ':impossible "Non-symbol ~S found where a slot name was expected."
			slot-name))
    (do ((slot-options slot-options (cddr slot-options)))
	((endp slot-options))
      (with-pattern-matching slot-options
	 ((`(:accessor ,accessor . ,ignore) t
	   (check-type accessor symbol)
	   (if (and (fboundp accessor) ; DAB 04-12-90
		    (not (generic-function-p accessor)))
	       (format t "~%**Warning:~a is not a generic function. Accessor option ignored!" accessor)
	       (progn 
		 (push accessor reader-list)
		 (push `(setf ,accessor) writer-list))))
	  (`(:reader ,reader . ,ignore) t
	   (check-type reader symbol)
	   (if (and (fboundp  reader) ; DAB 04-12-90
		    (not (generic-function-p reader)))
	       (format t "~%**Warning:~a is not a generic function. READER option ignored!" reader)
	       (push reader reader-list)
	       ))
	  (`(:writer ,writer . ,ignore) t
	   ;(check-type writer symbol)
	   (if (and (fboundp  writer) ; DAB 04-12-90
		    (not (generic-function-p writer)))
	       (format t "~%**Warning:~a is not a generic function. WRITER option ignored!" writer)
	       (push writer writer-list)
	       ))
	  (`(:initform ,initform . ,ignore ) t
	   (when initform-provided-p
	     (non-fatal-error ':impossible "Option ~S provided more than once for slot ~S."
			       (car slot-options) slot-name))
	   (setf initform-provided-p  t))
	  (`(:allocation ,allocation . ,ignore ) t
	   (when allocation-provided-p
	     (non-fatal-error ':impossible "Option ~S provided more than once for slot ~S."
			       (car slot-options) slot-name))
	   (unless (member allocation '(:instance :class))
	     (non-fatal-error ':impossible
		   "Invalid value ~S for ~S option."
		   (second slot-options) (car slot-options)))
	   (setf allocation-provided-p t))
	  (`(:type ,type . ,ignore ) t
	   (when type-provided-p
	     (non-fatal-error ':impossible "Option ~S provided more than once for slot ~S."
			       (car slot-options) slot-name))
	   (setf type-provided-p  t)
	   (unless (or (symbolp type)
		       (not compiler:qc-file-in-progress))
	     ;; Warn if not a valid type.
	     (compiler:canonicalize-type-for-compiler type slot-name)
	   ))
	  (`(:initarg ,initarg . ,ignore) t
	   (assert (typep initarg 'symbol) nil ":INITARG ~s should be a symbol" initarg )
	   (push initarg initargs))
	  (`(:documentation ,documentation . ,ignore ) t)
	  (t (non-fatal-error ':impossible "Unrecognized slot option ~s" (car slot-options))))))
    (when (eq allocation :class)
      (setq allocation (list :class class-name)))
    (when (and initform-provided-p
	       (not (eq type 't))
	       compiler:qc-file-in-progress
	       (constantp initform)
	       (sys:type-specifier-p type nil)
	       (not (typep (eval initform) type)))
      (non-fatal-error ':ignorable-mistake
		       "The init form for slot ~S is ~S which is inconsistent with its type declaration of ~S."
		       slot-name initform type)
      ;; Discard the type so that the compiler won't do optimizations based on 
      ;; a type declaration that is obviously not valid.
      (setq type t))
    (values
      (internal-make-slot-description :name slot-name
				      :writers writer-list
				      :readers reader-list
				      :initform (and initform-provided-p  (list initform))
				      :allocation allocation
				      :type type
				      :initargs initargs
				      )
      (let ((opts '()))
	(when (and documentation (record-documentation-p))
	  (push-key-and-value :documentation documentation opts))
	(unless (null initargs)
	  (push-key-and-value :initargs `',initargs opts))
	(unless (eq type 't)
	  (push-key-and-value :type `',type opts))
	(unless (eq allocation ':instance)
	  (push-key-and-value :allocation `',allocation opts))
	(when initform-provided-p
	  (unless (and (constantp initform)
		       (not (member initform '(nil t 0))))
	    (push-key-and-value :initclosure `(freeze ,initform) opts))
	  (push-key-and-value :initform `',(list initform) opts))
	(unless (null reader-list)
	  (push-key-and-value :readers `',reader-list opts))
	(unless (null writer-list)
	  (push-key-and-value :writers `',writer-list opts))
	`(internal-make-slot-description :name ',slot-name . ,opts)
	))))

))