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

;;; Reason: Fix (TYPEP x 'GENERIC-FUNCTION) to be consistent with CLASS-OF and with 
;;; method dispatch.  [SPR 10663]

;;;                           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 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 10/06/89 14:24:25 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent SYSTEM 6.20, 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.1, BASIC-NAMESPACE 6.4,
;;;  NETWORK-NAMESPACE 6.0, DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.4, MAC-PATHNAME 6.0,
;;;  NETWORK-PATHNAME 6.0, COMPILER 6.12, TV 6.15, DATALINK 6.0, CHAOSNET 6.1, 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.5, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1,
;;;  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.0, MAIL-DAEMON 6.3, MAIL-READER 6.5,
;;;  TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.2, PROFILE 6.2, VISIDOC 6.5, Inconsistent TI-CLOS 6.25,
;;;  CLEH 6.5, IP 3.50, Experimental CLX 6.4, CLUE 6.19, X11M 6.14, Experimental BUG 11.15,
;;;  Experimental DOCUMENTER 701.0,  microcode 430, Band Name: 6.0+Scribe,&c,u430 9/6

;;; BUG REPORT NUMBER:  10663
;;;
;;; PROBLEM:
;;;	If a method discriminates based on GENERIC-FUNCTION then the
;;;	object passed might not be of the type GENERIC-FUNCTION as
;;;	illustrated below.
;;;      
;;;     (defmethod test ((x ticlos:generic-function)) 
;;;	  (if (typep x 'ticlos:generic-function)
;;;	      (format t "Got the right thing") 
;;;	    (format t "Got the wrong thing")))
;;;
;;;     (defmethod test ((x t)) (format t "Got generic thing"))
;;;      
;;;     (test 42)
;;;
;;;     (test #'make-instance)
;;;      
;;;     The last form should result in "Got the right thing" being printed
;;;     out but doesn't.  It looks like the dispatch code knows enough to
;;;     treat #<DTP-FUNCTION MAKE-INSTANCE 4164460> as a generic function,
;;;     but TYPEP compiles into a TYPEP-STRUCTURE-OR-FLAVOR instruction
;;;     and gets it wrong.
;;;
;;;
;;; SOLUTION:  Define a SYS:TYPE-PREDICATE property for GENERIC-FUNCTION such 
;;;	that (TYPEP x 'GENERIC-FUNCTION) will be expanded to call the new function 
;;;	TYPEP-GENERIC-FUNCTION which checks for either the instance or generic FEF.
;;;	Also do likewise for STANDARD-GENERIC-FUNCTION and add a new method
;;;	(METHOD ADD-NAMED-CLASS :AFTER (FUNCALLABLE-STANDARD-CLASS)) to define a 
;;;	type predicate for any user-defined subclass of generic-function.

#!C
; From file GENERIC.LISP#> CLOS; Hotel:
#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; GENERIC.#"


;; 10/06/89 DNG - Added the following 4 forms to fix SPR 10663 -- (TYPEP x 
;;		'GENERIC-FUNCTION) should be true for either the instance or the FEF for 
;;		consistency with CLASS-OF and method dispatch.
(defun typep-generic-function (object &optional type)
  (or (si:typep-structure-or-flavor object (or type 'generic-function))
      (and (typep object 'compiled-function)
	   (zerop (sys:%p-ldb-offset sys:%%FEF-Storage-Length-Generic-Function-Flag object 1))
	   (or (null type)
	       (si:typep-structure-or-flavor (sys:get-debug-info-field (sys:get-debug-info-struct object)
								       :generic-function)
					     type)
	       ))))

(defprop generic-function typep-generic-function sys:type-predicate)  
(defprop standard-generic-function typep-standard-generic-function sys:type-predicate)  

(defsubst typep-standard-generic-function (object)
  (typep-generic-function object 'standard-generic-function))
))

#!C
; From file CLASS-REDEFINITION.LISP#> CLOS; Hotel:
#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-REDEFINITION.#"



;; 10/06/89 DNG - Added this method as part of fix for SPR 10663.
(defmethod add-named-class :after ((class-prototype funcallable-standard-class)
				   &key name environment &allow-other-keys)
  (let ((class (class-named name t environment)))
    (when (and (typep class 'funcallable-standard-class) ; class successfully defined.
	       (subtypep class 'generic-function))
      ;; Define type predicate so that TYPEP will accept either the instance or the associated FEF.
      (let ((predicate (gensym)))
	(eval `(defsubst ,predicate (object)
		 (typep-generic-function object ',name)))
	(setf (compiler:get-from-environment name 'sys:type-predicate nil environment)
	      predicate)
	))))
))