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

;;; Reason: Fixes for LCM [SPR 7112], (:PROPERTY COMPLEX TYPE-VALIDATOR) [SPR 8985], 
;;; WHO-CALLS [SPR 8961], SPECIAL-FORM-P [SPR 6922], 
;;; and INTERNAL-FUNCTION-SPEC-HANDLER [SPR 8669].
;;; Update WHO-CALLS to recognize SETF and LOCF functions.
;;; New functions for ANSI Common Lisp:   COMPLEMENT, CONSTANTLY, and  
;;; UPGRADED-ARRAY-ELEMENT-TYPE; new types BASE-CHARACTER and BASE-STRING.

;;;                           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 REL6H version 6.8
;;; Written 05/04/89 14:13:31 by GRAY,
;;; while running on Kelvin from band LODA
;;; With Experimental REL6H 6.7, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Inconsistent TI-CLOS 17.2, Experimental CLX 5.0, Experimental CLUE 20.0,
;;;  Experimental X11M 3.0, Experimental RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.4,
;;;  IP 3.42, Experimental DOCUMENTER 618.0,  microcode 426, Band Name: rel 6.0 + sle 5/3

#!C
; From file NUMBERS.LISP#> KERNEL; MR-X:
#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; NUMBERS.#"


(DEFUN lcm (&rest numbers)
  "Return the least common multiple of all the numbers."
  ;;  4/29/89 DNG - Fixed to permit no arguments.  [SPR 7112]
  (if (null numbers)
      1
    (DO ((value (ABS (first numbers)))
	 (REST (rest numbers) (CDR rest)))
	((NULL rest) value)
      (SETQ value (IF (OR (ZEROP value) (ZEROP (CAR rest)))
		      (RETURN 0)
		    (TRUNCATE (ABS (* value (CAR rest)))
			      (GCD value (CAR rest))))))))
))

(unless (eq (find-package "LISP") (FIND-PACKAGE "COMMON-LISP"))
  (export '( SYS:*GENSYM-COUNTER*
	    SYS:COMPLEMENT SYS:CONSTANTLY
	    COMPILER:DEBUG
	    TICL:DEFPACKAGE
	    TICLOS:DESCRIBE-OBJECT
	    TICL:DESTRUCTURING-BIND
	    TICL:FDEFINITION
	    SYS:FUNCTION-LAMBDA-EXPRESSION
	    COMPILER:LOAD-TIME-VALUE
	    TICLOS:MAKE-LOAD-FORM
	    TICLOS:MAKE-LOAD-FORM-SAVING-SLOTS
	    TICL:NTH-VALUE
	    TICLOS:OPEN-STREAM-P
	    TICL:REAL
	    TICL:REALP
	    SYS:UPGRADED-ARRAY-ELEMENT-TYPE
	    SYS:BASE-CHARACTER
	    SYS:EXTENDED-CHARACTER
	    SYS:BASE-STRING		
	    SYS:SIMPLE-BASE-STRING)
	  "COMMON-LISP"))


#!C
; From file FUNCTIONS.LISP#> KERNEL; MR-X:
#10R 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; FUNCTIONS.#"


;;  5/01/89 DNG - Added the following two functions for ANSI Common Lisp.
(proclaim '(compiler:try-inline complement constantly))
(defun complement (function)
  "Returns a function whose value is the same as the NOT of the given FUNCTION
applied to the same arguments."
  #'(lambda (&rest arguments)
      (not (apply function arguments))))

(defun constantly (value)
  "Returns a function whose value is always VALUE."
  #'(lambda (&rest arguments) 
      (declare (ignore arguments))
      value))

(defsubst constantly-t (&rest ignore) 't) ; used in optimization of CONSTANTLY
(defsubst constantly-0 (&rest ignore) '0) ; used in optimization of CONSTANTLY

))

#!C
; From file ARRAYS.LISP#> KERNEL; MR-X:
#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; ARRAYS.#"


;;  5/1/89 DNG - New for ANSI Common Lisp.
(DEFUN UPGRADED-ARRAY-ELEMENT-TYPE (TYPE)
  "Returns the element type of the most specialized array representation capable of
holding items of the given argument type."
  (CAR (RASSOC (ARRAY-TYPE-FROM-ELEMENT-TYPE type) array-element-type-alist :test #'EQ)))
(compiler:fold-constant-arguments 'UPGRADED-ARRAY-ELEMENT-TYPE)
))

#!C
; From file TYPES.LISP#> KERNEL; MR-X:
#10R 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; TYPES.#"


;;  5/1/89 DNG - The next 4 added for ANSI Common Lisp.  These don't 
;;		completely match the specified functionality, but are close enough for now.
(deftype base-character () 'string-char)
(deftype extended-character () `(and character (not string-char)))
(deftype base-string () 'string)
(deftype simple-base-string () 'simple-string)
))

#!C
; From file TYPES.LISP#> KERNEL; MR-X:
#10R 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; TYPES.#"


;; 5/01/89 DNG - Fix to not trap on a type which is not a symbol, class, or cons.
(defun typep-two-args (form &aux opt type pred dtp tem)
  (cond
    ((and (= (length form) 3) (constantp (caddr form)))
     (setq type (compiler:eval-for-target (caddr form)))
     ;;This takes care of constants evaluation
     (cond
       ((symbolp type)
	(cond
	  ((setq opt (get type 'type-optimizer)) (funcall opt form))
	  ((and (setq pred (get type 'type-predicate)) (symbolp pred)) `(,pred ,(cadr form))) ;; clm 03/06/89
	  ((setq dtp (rassoc type symbolic-type-of-alist :test #'eq))
	   `(= (%data-type ,(cadr form)) ,(car dtp)))
	  ((compilation-flavor type (just-compiling)) `(typep-structure-or-flavor ,(cadr form) ',type))
	  ((getdecl type 'defstruct-description) `(typep-structure-or-flavor ,(cadr form) ',type))
	  ((typep-structure-or-flavor (ticlos:class-named type t compiler:*compile-file-environment*)
				      'ticlos:standard-class)
	   `(typep-structure-or-flavor ,(cadr form)
				       (sys:eval-at-load-time (ticlos:class-named ',type :create))))
	  ((setq tem (get type 'type-alias-for)) `(typep ,(cadr form) ',tem))
	  ((setq tem (getdecl type 'type-expander)) `(typep ,(cadr form) ',(funcall tem)))
	  (t form)))
       ((classp type)
	`(typep-structure-or-flavor ,(cadr form) ',type))
       ((consp type)
	(cond
	  ((setq opt (get (car type) 'type-optimizer)) (apply opt form (cdr type)))
	  ((setf tem (getdecl (car type) 'type-expander))
	   `(typep ,(cadr form) ',(apply tem (cdr type))))
	  (t form)))
       (t form)))
    (t form)))
))

#!C
; From file TYPES.LISP#> KERNEL; MR-X:
#10R 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; TYPES.#"


;;  5/2/89 DNG - Fixed for SPR 8985.
(defun (:property complex type-validator) (&rest args)
  (or (null args)
      (and (< (length args) 2)
	   (type-specifier-p (first args))
	   (values (subtypep (first args) 'real)))))
))

#!C
; From file WHO-CALLS.LISP#> KERNEL; MR-X:
#10R 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; WHO-CALLS.#"


;;  5/02/89 DNG - Add support for SETF and LOCF functions.

(defun who-calls (symbol-or-symbols &optional pkg (inheritors t) (inherited t))
  "Find all symbols in package PKG whose values, definitions or properties use SYMBOL.
SYMBOL-OR-SYMBOLS can be a symbol or a list of symbols, each of which is looked for.
PKG defaults to NIL, which means search all packages.
The packages which inherit from PKG are processed also, unless INHERITORS is NIL.
The packages PKG inherits from are processed also, unless INHERITED is NIL.
\(Other packages which merely inherit from the same ones are NOT processed.)
The symbols are printed and a list of them is returned.
The symbol :UNBOUND-FUNCTION is special:  (WHO-CALLS :UNBOUND-FUNCTION)
will find all functions that are used but not currently defined."
  (let ((return-list nil))
    (declare (special return-list))
    (find-callers-of-symbols symbol-or-symbols pkg
			     #'(lambda (caller callee how)
				 (format t "~&~S" caller)
				 (format t (case how
					     (:variable " uses ~S as a variable.")
					     (:function " calls ~S as a function.")
					     (:instruction " uses an instruction for the ~S function.")
					     (:constant " uses ~S as a constant.")
					     (:flavor " uses ~S's flavor definition.")
					     (:unbound-function " calls ~S, an undefined function.")
					     (:macro " calls ~S as a macro.")
					     (setf " calls function (SETF ~S).")
					     (locf " calls function (LOCF ~S).")
					     (nil ", an interpreted function, uses ~S somehow.")
					     (t " uses ~S somehow."))
					 callee)
				 (push caller return-list))
			     inheritors inherited)
    return-list))
))


#!C
; From file WHO-CALLS.LISP#> KERNEL; MR-X:
#10R 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; WHO-CALLS.#"



;;  5/02/89 DNG - Fixed to handle value which is not a list.  [SPR 8961]
(defun add-symbols-optimized-into (sym list)
  (let ((prop (get sym 'compiler:optimized-into)))
    (if (listp prop)
	(dolist (sym1 prop)
	  (unless (member sym1 (the list list) :test #'eq)
	    (setq list (add-symbols-optimized-into sym1 (cons sym1 list)))))
      (unless (member prop (the list list) :test #'eq)
	(setq list (add-symbols-optimized-into prop (cons prop list))))))
  list)

;;  5/2/89 DNG - Updated to recognize and scan SETF and LOCF functions.
(defun find-callers-of-symbols-aux (caller symbol function)
  ;; Ignore all symbols which are forwarded to others, to avoid duplication.
  (when (and (/= (%p-data-type-offset caller 2) dtp-one-q-forward)
	     (fboundp caller))
    (find-callers-of-symbols-aux1 caller (symbol-function caller) symbol function))
  (when (/= (%p-data-type-offset caller 3) dtp-one-q-forward)
    ;; Also look for properties
    (loop for (prop value) on (symbol-plist caller) by #'cddr
	  if (= (%data-type value) dtp-function)
	  do (find-callers-of-symbols-aux-fef (list :property caller prop)
					      value symbol function)
	  else if (and (consp value)
		       (consp (car value))
		       (consp (cdr (car value)))
		       (eq caller (second (car value)))
		       (si:validate-function-spec (car value)))
	  do (let ((defn (fdefinition-safe (car value) nil)))
	       (when (and defn (member defn (cdr value) :test #'eq))
		 ;; here for SETF and LOCF functions
		 (find-callers-of-symbols-aux1 (car value)
					       (fdefinition-safe (car value) t)
					       symbol
					       function))))
    ;; Also look for flavor methods
    (let (fl)
      (when (and (setq fl (get caller 'flavor))
		 (arrayp fl))			;Could be T
	(dolist (mte (flavor-method-table fl))
	  (dolist (meth (cdddr mte))
	    (if (meth-definedp meth)
		(find-callers-of-symbols-aux1 (meth-function-spec meth)
					      (meth-definition meth)
					      symbol function))))))
    ;; Also look for initializations
    (when (get caller 'initialization-list)
      ;; It is an initialization list.
      (dolist (init-list-entry (symbol-value caller))
	(find-callers-of-symbols-aux-list caller (init-form init-list-entry) symbol function))))) 


;;;PHD 4/1/87 SPR 4459, make this function more robust, follow things only of DEFN is a function.
;;;DNG 8/5/87 SPR 4575, fix to handle closures.
;;;DNG 4/3/89 - Add handling for methods of generic functions.
;;;DNG 5/2/89 - Fix to not error on generic function names in interpreted code.
(defun find-callers-of-symbols-aux1 (caller defn symbol function)
  ;; Don't be fooled by macros, interpreted or compiled.
  (when (functionp defn t)
    (when (and (consp defn) (eq (car defn) 'macro))
      (setq defn (cdr defn)))
    (typecase defn
      (compiled-function (find-callers-of-symbols-aux-fef caller defn symbol function))
      (list (find-callers-of-symbols-aux-lambda caller defn symbol function))
      (closure
       (when (eql (%data-type defn) dtp-closure)
	 (dolist (sym (closure-variables defn))
	   (when (if (atom symbol)
		     (eq sym symbol)
		   (member sym (the list symbol) :test #'eq))
	     (funcall function caller sym :variable))))
       (find-callers-of-symbols-aux1 caller (closure-function defn) symbol function)))
    ;; If this function is traced, advised, etc.
    ;; then look through the actual definition.
    (when (or (listp defn) (typep defn 'compiled-function))
      (let* ((debug-info  (get-debug-info-struct defn))
	     (inner  (car (get-debug-info-field debug-info 'si:encapsulated-definition))))
	(when inner
	  (find-callers-of-symbols-aux inner symbol function))))
    (locally
      (declare (notinline ticlos:generic-function-p ticlos:generic-function-methods ticlos:method-function))
      (when (and (ticlos:generic-function-p defn)
		 (not (symbolp defn)))
	(dolist (method (ticlos:generic-function-methods defn))
	  (let ((fef (ticlos:method-function method)))
	    (find-callers-of-symbols-aux1 (function-name fef) fef symbol function)))))
    (values)))

(unless (fboundp 'ticlos:generic-function-p)
  (setf (symbol-function 'ticlos:generic-function-p) #'ignore))

;;; 10/13/87 CLM - Fixes problem when given a macro in a list of symbols to search for.
;;;	We were printing the whole list; now it correctly prints just the macro name. [SPR 6648]
;;;  4/25/89 DNG - Add use of :CONSTANTS-OPEN-CODED debug info for SPR 6501.
;;;  5/02/89 DNG - Add handling for calls to SETF and LOCF functions.
(defun find-callers-of-symbols-aux-fef (caller defn symbol function)
  (do ((i %fef-header-length (1+ i))
       (lim (truncate (fef-initial-pc defn) 2))
       tem offset sym)
      ((>= i lim) nil)
    (cond ((= (%p-data-type-offset defn i) dtp-external-value-cell-pointer)
	   (setq tem (%p-contents-as-locative-offset defn i)
		 sym (%find-structure-header tem)
		 offset (%pointer-difference tem sym))
	   (cond ((not (symbolp sym))
		  (when (and (= offset 1)
			     (consp sym)
			     (consp (car sym))
			     (if (atom symbol)
				 (eq (second (car sym)) symbol)
			       (member (second (car sym)) (the list symbol) :test #'eq))
			     (validate-function-spec (car sym)))
		    ;; here for a call to a SETF or LOCF function.
		    (funcall function caller (second (car sym)) (caar sym))))
		 ((= offset 2)			;Function cell reference
		  (if (if (atom symbol)
			  (eq sym symbol)
			  (member sym (the list symbol) :test #'eq))
		      (funcall function caller sym :function)
		    (when (and (if (atom symbol)
				   (eq :unbound-function symbol)
				 (member :unbound-function (the list symbol) :test #'eq))
			       (not (fboundp sym)))
		      (funcall function caller sym :unbound-function))))
		 (t				;Value reference presumably
		  (when (if (atom symbol)
			    (eq sym symbol)
			    (member sym (the list symbol) :test #'eq))
		    (funcall function caller sym :variable)))))
	  ((= (%p-data-type-offset defn i) dtp-self-ref-pointer)
	   (let ((fn (fef-flavor-name defn)))
	     (if fn
		 (multiple-value-bind (sym use)
		     (flavor-decode-self-ref-pointer fn (%p-pointer-offset defn i))
		   (if (or (eq sym symbol)
			   (and (consp symbol)
				(member sym (the list symbol) :test #'eq)))
		       (funcall function caller sym
				(if use :flavor :variable)))))))
	  ((symbolp (setq sym (%p-contents-offset defn i)))
	   (when (if (atom symbol)
		     (eq sym symbol)
		     (member sym (the list symbol) :test #'eq))
	     (funcall function caller sym :constant)))))
  ;; See if the fef uses the symbol as a macro.
  (let ((di  (get-debug-info-struct defn)))
    (dolist (m  (get-debug-info-field di :macros-expanded))
      (let ((macro-symbol (if (consp m) (car m) m)))
	(when (if (atom symbol)
		  (eq symbol
		      macro-symbol)
		  (member macro-symbol
			  (the list symbol)
			  :test #'eq))
	  (funcall function caller macro-symbol :macro))))
    ;; See if the symbol names a DEFCONSTANT that was expanded in the FEF.
    (dolist (m  (get-debug-info-field di :constants-open-coded))
      (let ((constant-symbol (if (consp m) (car m) m)))
	(when (if (atom symbol)
		  (eq symbol constant-symbol)
		  (member constant-symbol (the list symbol) :test #'eq))
	  (funcall function caller constant-symbol :variable)))))
  ;; See if we have a function reference compiled into a misc instruction
  (if (symbolp symbol)
      (let ((misc-function (fef-calls-misc-function defn symbol)))
	(when misc-function
	  (funcall function caller symbol misc-function)))
      (dolist (sym symbol)
	(let ((misc-function (fef-calls-misc-function defn sym)))
	  (when misc-function
	    (funcall function caller sym misc-function)))))
  (let ((tem  (get-debug-info-field (get-debug-info-struct defn) :internal-fef-offsets)))
    (loop for offset in tem
	  for i from 0
	  when (numberp offset)
	  do (find-callers-of-symbols-aux-fef `(:internal ,caller ,i)
					      (%p-contents-offset defn offset)
					      symbol function))))
))

#!C
; From file FUNCTIONS.LISP#> KERNEL; MR-X:
#10R 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; FUNCTIONS.#"


;; DNG 5/2/89 Fix to return NIL for definition which is a list but not a function.  [SPR 6922]
(DEFUN SPECIAL-FORM-P (symbol)
  "a predicate returning t if <symbol> has a function definition whose lambda list contains &quote."
  (WHEN (FBOUNDP symbol)
    (LET ((fct-binding (SYMBOL-FUNCTION symbol)))
      (TYPECASE fct-binding
	(compiled-function
	 (COMPILED-SPECIAL-FORM? fct-binding))
	(cons  ;;7/13/88 clm
	 (AND (MEMBER (CAR fct-binding) FUNCTION-START-SYMBOLS :TEST #'EQ)
	      (MEMBER '&QUOTE (ARGLIST fct-binding t) :test #'EQ) 
	      t))
	(symbol (special-form-p fct-binding))
	(T NIL)
	))))
))

#!C
; From file FUNCTIONS.LISP#> KERNEL; MR-X:
#10R 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; FUNCTIONS.#"


(DEFUN INTERNAL-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
  ;;  7/13/85 DNG - Added support for named internal functions.
  ;; 11/04/85 DNG - Modifications to speed up handling of deeply nested
  ;;                functions by avoiding repetitive recursion.  [SPR 594]
  ;;                Also avoid errors on FDEFINEDP for arguments that pass VALIDATE-FUNCTION-SPEC.
  ;;  5/19/86 DRH - changed DTP-FEF-POINTER to DTP-FUNCTION and calls to DEBUGGING-INFO to
  ;;                GET-DEBUG-INFO-STRUCT & -FIELD
  ;; PHD 12/31/86 - Added support for lexical-closure parent.
  ;; DNG  5/02/89 - Permit FUNCTION-PARENT even if parent name isn't defined.  [SPR 8669]
  (LET ((PARENT (SECOND FUNCTION-SPEC))
	(INDEX (THIRD FUNCTION-SPEC))
	DIRECT-FEF)
    (SETQ DIRECT-FEF (= (%DATA-TYPE PARENT) DTP-FUNCTION))
    (IF (NOT (AND (OR (AND (FIXNUMP INDEX)
			   (NOT (MINUSP INDEX)))
		      (SYMBOLP INDEX))
		  (= (LENGTH FUNCTION-SPEC) 3)))
	(UNLESS (EQ FUNCTION 'VALIDATE-FUNCTION-SPEC)
	  (INVALID-FUNCTION-SPEC FUNCTION-SPEC))
	(IF (EQ FUNCTION 'VALIDATE-FUNCTION-SPEC)
	    (OR DIRECT-FEF
		(AND (VALIDATE-FUNCTION-SPEC PARENT)
		     (OR (EQ (CAR-SAFE PARENT) ':INTERNAL)	; avoid repetition
			 (FDEFINEDP PARENT))))
	    (LET ((FEF (IF DIRECT-FEF
			   PARENT
			   (OR (FDEFINITION-SAFE PARENT T)	; unencapsulated definition
			       (IF (EQ FUNCTION 'FDEFINEDP)
				   (RETURN-FROM INTERNAL-FUNCTION-SPEC-HANDLER NIL)
				 (IF (EQ FUNCTION 'FUNCTION-PARENT)
				     (RETURN-FROM INTERNAL-FUNCTION-SPEC-HANDLER (VALUES PARENT 'DEFUN))
				   (FERROR 'SYS:INVALID-FUNCTION-SPEC
					   "The function spec ~S refers to ~S, which is not defined."
					   FUNCTION-SPEC PARENT)) ))))
		  TABLE OFFSET)
	      (declare (unspecial fef))
	      (AND (CONSP FEF) (EQ (CAR FEF) 'MACRO)
		   (SETQ FEF (CDR FEF)))
	      (when (typep fef 'lexical-closure)
                (setf fef (closure-function fef)))
	      (OR (= (%DATA-TYPE FEF) DTP-FUNCTION)
		  (FERROR 'SYS:INVALID-FUNCTION-SPEC
			  "The function spec ~S refers to ~S, which is not a FEF."
			  FUNCTION-SPEC FEF))
	      (LET (( DEBUG-INFO (GET-DEBUG-INFO-STRUCT FEF) ))
		(UNLESS (SETQ TABLE (GET-DEBUG-INFO-FIELD debug-info :INTERNAL-FEF-OFFSETS))
		  (IF (EQ FUNCTION 'FDEFINEDP)
		      (RETURN-FROM INTERNAL-FUNCTION-SPEC-HANDLER NIL)
		      (FERROR 'SYS:INVALID-FUNCTION-SPEC
			      "The function spec ~S refers to ~S, which has no internal functions."
			      FUNCTION-SPEC FEF)))
		(UNLESS (FIXNUMP INDEX)
		  (SETQ INDEX 
			(OR (POSITION INDEX (THE LIST (GET-DEBUG-INFO-FIELD debug-info :INTERNAL-FEF-NAMES))
				      :TEST #'EQ)
			    (IF (EQ FUNCTION 'FDEFINEDP)
				(RETURN-FROM INTERNAL-FUNCTION-SPEC-HANDLER NIL)
				(FERROR 'SYS:INVALID-FUNCTION-SPEC
					"The function spec ~S is invalid -- no ~S found in ~S."
					FUNCTION-SPEC INDEX PARENT)))) ) )
	      (UNLESS (SETQ OFFSET (NTH INDEX TABLE))
		(IF (EQ FUNCTION 'FDEFINEDP)
		    (RETURN-FROM INTERNAL-FUNCTION-SPEC-HANDLER NIL)
		    (FERROR 'SYS:INVALID-FUNCTION-SPEC
			    "The function spec ~S is out of range." FUNCTION-SPEC)))
	      
	      ;; Function spec fully parsed, we can now earn our living
	      (CASE FUNCTION
		    (VALIDATE-FUNCTION-SPEC T)
		    (FDEFINE (LET ((%INHIBIT-READ-ONLY T))
			       (%P-STORE-CONTENTS-OFFSET ARG1 FEF OFFSET)))
		    (FDEFINITION (%P-CONTENTS-OFFSET FEF OFFSET))
		    (FDEFINEDP			;Random: look for what the compiler puts there initially
		     (LET (( DEF (%P-CONTENTS-OFFSET FEF OFFSET)))
		       ;; FDEFINITION-SAFE uses the second value returned to avoid having to
		       ;; call this routine again to get the definition.
		       (VALUES (NOT (EQUAL DEF FUNCTION-SPEC))
			       DEF ) ) )
		    (FDEFINITION-LOCATION (%MAKE-POINTER-OFFSET DTP-LOCATIVE FEF OFFSET))
		    (FUNCTION-PARENT (VALUES PARENT 'DEFUN))
		    (OTHERWISE (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2))))))))
))

#!C
; From file PREDICATES.LISP#> KERNEL; MR-X:
#10R 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; PREDICATES.#"


(Defsubst INSTANCEP (object)
  "T if OBJECT is an instance of a flavor or standard-class."
  (declare (:expr-sxhash 6400274.)) ; 5/3/89 DNG
  (= (%data-type object) dtp-instance))
))

#!C
; From file TYPES.LISP#> KERNEL; MR-X:
#10R 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; TYPES.#"


;; 5/04/89 DNG - Bind *LOCAL-ENVIRONMENT* around calls to validator functions 
;;		so that the correct environment will be used by any recursive calls to 
;;		TYPE-SPECIFIER-P from the validator.
(defun type-specifier-p (type &optional (environment compiler:*local-environment*))
  "Returns T on valid type specifiers, NIL on any other object."
  (multiple-value-bind
    (expanded-type error-p )
      (ignore-errors (type-canonicalize type environment))
    (if error-p nil
	(let (fn)
	  (when (member expanded-type '(nil structure ratio atom bignum null random-state t
					    common	;(or number ...... )
					    fat-char	;(and character (satisfies ....)
					    keyword	;(and symbol (satisfies keywordp ))
					    list	;(or null cons)
					    number	; (or complex real)
					    real	; (or rational float)
					    ))
	    (return-from type-specifier-p t))
	  (typecase expanded-type
	    (symbol (not (null
			   (cond
			     ((setq fn (get expanded-type 'type-validator))
			      (let ((compiler:*local-environment* environment))
				(funcall fn)))
			     ((rassoc expanded-type type-of-alist
				      :test #'(lambda (expanded-type cons)
						(if (consp cons)
						    (member expanded-type cons :test #'eq)
						    (eq expanded-type cons))))
			      t)
			     ((getdecl expanded-type 'type-predicate nil environment) t)
			     ((get-flavor expanded-type environment) t)
			     ;; check for typed structure
			     ((getdecl expanded-type 'defstruct-description nil environment) t)
			     ((ticlos:class-named expanded-type t environment) t)
			     ))))
	    (list (and (setq fn (get (first expanded-type) 'type-validator))
		       (let ((compiler:*local-environment* environment))
			 (apply fn (rest expanded-type)))))
	    (ticlos:class t)
	    (t nil))))))
))