;;; -*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

1;;;                           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
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.

;****************************************************************************************
;
;  the reader macros ZETALISP, DWIMIFY and RECORD-SOURCE-FILES are used
;
;*****************************************************************************************

;; 11/15/86 DNG - Moved the definitions of DEFUN, DEFSUBST, PROCESS-DEFUN-BODY, 
;;		DEFF, DEF, and FUNCTION-START-SYMBOLS to new file FUNCTION-MACROS.
;;		Deleted STORE-KEYWORD-ARG-VALUES which is no longer used.  Mark
;;		EXTRACT-DECLARATIONS and FDEFINEDP-AND-FDEFINITION obsolete.
;;		Updates to FDEFINE and STRING-LESSP [see comments there].
;; later...that same afternoon...drh moved unenapsulate-function-spec and record-source-file
;; to the file COLD-LOAD-UNCAPS-RECORD
;; 7/13/88 CLM - In SPECIAL-FORM-P, changed TYPECASE selector from LIST to CONS to prevent
;;               error if symbol has nil in function cell.  This was a problem occurring in
;;               Scheme (sprs 6922 and 7452)
;; 3/15/89 DNG - Updated PARSE-BODY for CLOS.
;; 3/17/89 DNG - Introduced new function INVALID-FUNCTION-SPEC.  
;;		Enhance FUNCTION-SPEC-GET to accept an optional default value.

;;6/17/86 PHD Added support for flavor declarations.
(DEFPARAMETER *DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*
	  '((ARGLIST	  . :DESCRIPTIVE-ARGLIST)
	    (RETURN-LIST  . :VALUES)
	    (VALUES	  . :VALUES)
	    (:ARGLIST	  . :DESCRIPTIVE-ARGLIST)
	    (:RETURN-LIST . :VALUES)
	    (:VALUES	  . :VALUES)
	    (FUNCTION-PARENT . :FUNCTION-PARENT)
	    (COMPILER:COMPILER-ARGLIST . :ARGLIST)
	    (WRAPPER-SXHASHES . WRAPPER-SXHASHES)
	    (COMBINED-METHOD-DERIVATION . COMBINED-METHOD-DERIVATION))
  1"Local declaration types which are incorporated into the function debugging info.
Each element is (DECLARATION . DEBUG-INFO-KEYWORD).
Note that there are many synonyms among the declarations."*)

1;;; if FORM is defined as the list
;;;      '((X Y Z) 
;;;*	1   "this is a test doc-string"
;;;*	1   (DECLARE (ARGLIST (X Y Z)) 
;;;*                  1(VALUES (+ X Y Z)) (SPECIAL icky pick wicky) (inline mumble) (income tax))
;;;*	1   (+ x y z)))
;;; then (PARSE-BODY (CDR FORM) nil t) would return three values:
;;;  1) ((+ X Y Z))
;;;  2) ((DECLARE (ARGLIST (X Y Z)) 
;;;*                 1(VALUES (+ X Y Z)) (SPECIAL ICKY PICK WICKY) (INLINE MUMBLE) (INCOME TAX)))
;;;  3) "this is a test doc-string"
;;; and (PROCESS-DEFUN-BODY 'foo form nil t) would return the list
;;;  (NAMED-LAMBDA 
;;;      (FOO (:DESCRIPTIVE-ARGLIST (X Y Z)) (:VALUES (+ X Y Z))) (X Y Z) 
;;;      "this is a test doc-string" 
;;;      (DECLARE (SPECIAL ICKY PICK WICKY) (INLINE MUMBLE) (INCOME TAX)) 
;;;      (BLOCK FOO (+ X Y Z)))*

;;  3/15/89 DNG - Don't macroexpand LOAD-TIME-VALUE or macros in the LISP or CLOS packages.
(Defun PARSE-BODY (body environment &OPTIONAL (doc-string-allowed t))
  1"This function is to parse the declarations and doc-string out
 2 *of the body2 *of a defun-like form.  Body is the list to be parsed2 and consists
  of everything after the formal parameter list.*
  Environment is the lexical environment to expand macros in.  If
  Doc-String-Allowed is true, then a doc string will be parsed out of the body
  and returned.  If it is false then a string will terminate the search for
  declarations.  Three values are returned: the tail of Body after the
  declarations and doc strings, a list of declare forms, and the doc-string,
  or NIL if none."*
  (DECLARE (VALUES body decs doc-string))
  (LET (decls
	doc)
    (DO ((tail body (CDR tail)))
	((ENDP tail)
	 (VALUES tail 
		 (NREVERSE (the list decls)) 
		 doc))
      (LET ((form (CAR tail)))
	(COND ((AND (STRINGP form) (CDR tail))
	       (IF doc-string-allowed
		   (SETQ doc form)
		   (RETURN (VALUES tail 
				   (NREVERSE (the list decls))
				   doc))))
	      ((NOT (AND (CONSP form) (SYMBOLP (CAR form))))
	       (RETURN (VALUES tail
			       (NREVERSE (the list decls))
			       doc)))
	      ((EQ (CAR form) 'declare)
	       (PUSH form decls))
	      ((or ;; No macros in the LISP package expand to declarations; don't 
		 ;; want to waste time expanding things like WITH-SLOTS which we know 
		 ;; aren't declarations.
		 (let ((pkg (symbol-package (car form))))
		   (or (eq pkg *lisp-package*)
		       (eq pkg (symbol-package 'ticlos:with-slots))))
		 ;; Would be wrong to expand LOAD-TIME-VALUE now.
		 (eq (car form) 'compiler:LOAD-TIME-VALUE))
	       ;; Don't try to macroexpand.
	       (RETURN (VALUES tail
			       (NREVERSE (the list decls))
			       doc)))
	      (t
	       (MULTIPLE-VALUE-BIND (res win)
		   (CATCH-ERROR (MACROEXPAND form environment) nil) ;; supress error message, if any
		 (IF (AND win (CONSP res) (EQ (CAR res) 'declare))
		     (PUSH res decls)
		     (RETURN (VALUES tail
				     (NREVERSE (the list decls))
				     doc))))))))))


(Defun FLATTEN-DECLARATIONS (list-of-declarations)
;;; A utility called upon to convert a list of declarations such as
;;;  ((declare (integer x y) (special x)) (declare (inline frob))
;;; to a list
;;;  ((integer x y)(special x)(inline frob))
;;; For an example of how this is used, see the macro WITH-OUTPUT-TO-STRING.
  (LET ((declist))
    (DOLIST (x list-of-declarations)   ;; x looks like (declare (...)(...) ... (...))
      (DOLIST (y (cdr x))
	(PUSH y declist)))
    (NREVERSE (the list declist))))1  ;; return ((...)(...)...(...))*



(DEFUN FUNCTIONP (fct &OPTIONAL allow-special-forms)
  1"a predicate for functions, i.e. (functionp f) is true when <f> is a function object.
   Special forms and macros will be considered only if ALLOW-SPECIAL-FORMS is true."*

  (TYPECASE fct
    (compiled-function
     (OR allow-special-forms (NOT (COMPILED-SPECIAL-FORM? fct))))
    (microcode-function t)
    ((OR closure lexical-closure) t)
    (list
     (COND ((MEMBER (CAR fct) function-start-symbols :TEST #'EQ)
	    (OR allow-special-forms (NOT (MEMBER '&quote (ARGLIST fct t)))))
	   ((EQ (CAR fct) 'macro) allow-special-forms)
	   (T nil)))
    (symbol
     (WHEN (FBOUNDP fct)
       (IF (ARRAYP (SYMBOL-FUNCTION fct)) t 
	   (FUNCTIONP (SYMBOL-FUNCTION fct) allow-special-forms))))))

;;;03/20/89 clm for DNG - integrated into Kernel.
(defun 4function-spec-p* (spec)
"2Non-nil if the thing passed to it is a valid function spec.*"
  (or (symbolp spec)
      (and (consp spec)
	   (symbolp (first spec))
	   (get (first spec) 'function-spec-handler))))

;;PHD-PAD 1/21/87 Fixed it so it follows symbol-function being symbols (see locally).
;; 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)
	))))



1;; (SETF (SYMBOL-FUNCTION symbol) defintion) expands into a FSET*

(DEFUN SYS:FSET (SYMBOL DEFINITION)
1  "Set the function definition of SYMBOL to DEFINITION.
  This should not be used directly because no warnings will be given,
  no source files recorded, no encapsulations preserved, etc. Use
  DEFUN or FDEFINE."*

  (CHECK-TYPE symbol SYMBOL "a symbol")
  (RPLACA (FUNCTION-CELL-LOCATION symbol) definition)
  definition)

(DEFF GLOBAL:FSET #'SYS:FSET)


(DEFUN FDEFINE (function-spec definition &OPTIONAL carefully-flag no-query-flag)
1  
  "Alter the function definition of a function specifier.
CAREFULLY-FLAG means preserve any tracing or advice,
and save the old definition, when possible.
    This function returns T if it does define the function, or NIL if it does not.
If FDEFINE-FILE-PATHNAME is non-NIL, then it is the file which this definition
was read from, and we make a note of that fact when possible."*

  ;; 11/13/86 DNG - Use FDEFINITION-SAFE instead of FDEFINEDP-AND-FDEFINITION;
  ;;		prevent circular definitions of symbols; copy indentation information when
  ;;		defining an alias [previously done in DEFF-MACRO].
  
  ;; Get error if invalid fun spec.  Also find out whether defined.
  (LET ((definedp (FDEFINEDP function-spec))
	(type     (IF (CONSP function-spec) (CAR function-spec)))
	inner-spec)

    ;; Record the source file name, if desired, and check for redefinition errors
    (COND ((OR (EQ type :INTERNAL)
	       (RECORD-SOURCE-FILE-NAME function-spec
					(IF carefully-flag 'DEFUN 'ENCAPSULATION)
					(OR no-query-flag (NOT carefully-flag)
					    (EQ inhibit-fdefine-warnings T))))
	       
	   
	   1;; If there is a previous definition, save it (if desired).*
	1   ;; Also if it is encapsulated, set INNER-SPEC to the symbol*
	1   ;; which holds the real definition before encapsulation, and*
	1   ;; save that definition.*
	1   *(COND ((AND definedp carefully-flag)
		  (SETQ inner-spec (UNENCAPSULATE-FUNCTION-SPEC function-spec))
		  (LET ((defn (FDEFINITION-SAFE inner-spec)))
		    (WHEN defn
		      (FUNCTION-SPEC-PUTPROP function-spec defn :PREVIOUS-DEFINITION)))
		  ;; Carry over renamings from previous definition
		  (AND (NEQ function-spec inner-spec)	;skip it if no encapsulations.
		       (FBOUNDP 'RENAME-WITHIN-NEW-DEFINITION-MAYBE)
		       (SETQ definition (RENAME-WITHIN-NEW-DEFINITION-MAYBE function-spec
									    definition))))
		 (T (SETQ inner-spec function-spec)))
	   
	   ;; Now store the new definition in type-dependent fashion
	   (IF (SYMBOLP inner-spec)
	       (PROGN (WHEN (EQ inner-spec definition)
			;; disallow since it will hang the microcode in an infinite loop
			(FERROR NIL "Attempt to use the symbol ~S as its own function definition." inner-spec))
		      (FSET inner-spec definition)
		      (WHEN (SYMBOLP DEFINITION)
			(DEFMACRO-COPY-INDENTATION-FOR-ZWEI inner-spec definition)))
	       (FUNCALL (GET type 'FUNCTION-SPEC-HANDLER) 'FDEFINE inner-spec definition))
	   
	   ;; Return T since we did define the function
	   T) 
	  
	  ;; Return NIL since we decided not to define the function
	  (T NIL))))


(DEFUN FUNCTION-NAME (fct &OPTIONAL return-flavor-names-flag)
  9"Return <fct>'s name, if known.  Otherwise return <fct>.
  RETURN-FLAVOR-NAMES-FLAG, if T, says that if <fct> is a flavor instance
  then the flavor name should be returned.  Otherwise <fct> is returned.
  The second value is T if a name was known."*
  (TYPECASE fct
    (COMPILED-FUNCTION
     (VALUES (GET-DEBUG-INFO-FIELD (GET-DEBUG-INFO-STRUCT fct) :NAME) T))
    (MICROCODE-FUNCTION
     (VALUES (GET-DEBUG-INFO-FIELD (GET-DEBUG-INFO-STRUCT fct) :NAME) T))
    (STACK-GROUP
     (VALUES (ARRAY-LEADER fct SG-NAME) T))
    (LIST
     (COND ((MEMBER (CAR fct) '(NAMED-LAMBDA NAMED-SUBST 
					     CLOSURE-NAMED-LAMBDA GLOBAL:NAMED-SUBST GLOBAL:NAMED-LAMBDA) :TEST #'EQ)
	    (VALUES
	      (IF (SYMBOLP (CADR fct)) (CADR fct) (CAADR fct))
	      T))
	   ((EQ (CAR fct) 'MACRO)
	    (FUNCTION-NAME (CDR fct) return-flavor-names-flag))
	   (T fct)))
    (CLOSURE
     (FUNCTION-NAME (CLOSURE-FUNCTION fct)))
    (INSTANCE      ;; Return the flavor name.  Best we can do.
     (IF return-flavor-names-flag
	 (VALUES (TYPE-OF fct) T)
	 fct))
    (SYMBOL
     (COND ((NULL fct) NIL)
	   ((AND (FDEFINEDP fct) (SYMBOLP (FDEFINITION fct)))
	    (FUNCTION-NAME (FDEFINITION fct)))
	   (T (VALUES fct T))))
    (T fct)))

1;; A function-specifier is just a way of talking about a function
;; for purposes other than applying it.  It can be a symbol, in which case
;; the function cell of the symbol is used.  Or it can be a list of one of
;; these formats:
;; (:METHOD class-name operation) refers to the method in that class for
;;   that operation; this works for both Class methods and Flavor methods.
;;   In the case of Flavor methods, the specification may also be of the form
;;   (:METHOD flavor-name type operation).
;; (:HANDLER flavor operation) refers to the function that is called when
;;   an object of flavor FLAVOR is sent the message OPERATION.
;; (:WITHIN within-function renamed-function) refers to renamed-function,
;;   but only as called directly from within-function.
;;   Actually, renamed-function is replaced throughout within-function
;;   by an uninterned symbol whose definition is just renamed-function
;;   as soon as an attempt is made to do anything to a function spec
;;   of this form.  The function spec is from then on equivalent
;;   to that uninterned symbol.
;; (:PROPERTY symbol property) refers to (GET symbol property).
;; (:LOCATION locative-or-list-pointer) refers to the CDR of the pointer.
;;   This is for pointing at an arbitrary place
;;   which there is no special way to describe.
;; One place you can use a function specifier is in DEFUN.
;*
; For Maclisp compatibility, a list whose car is not recognized is taken
; to be a list of a symbol and a property, by DEFUN and DEFMACRO.  They
; standardize this by putting :PROPERTY on the front.  These
; non-standard function specs are not accepted by the rest of the
; system.  This is done to avoid ambiguities and inconsistencies.

;The SYS:FUNCTION-SPEC-HANDLER property of a symbol, if present means that that
;symbol is legal as the car of a function spec.  The value of the property
;is a function whose arguments are the function in behalf
;of which to act (not a keyword symbol!) and the arguments to that
;function (the first of which is always the function spec).
;Functions are:
;	FDEFINE definition
;	FDEFINEDP
;	FDEFINITION
;	FDEFINITION-LOCATION
;	FUNDEFINE
;	FUNCTION-PARENT
;	COMPILER-FDEFINEDP -- returns T if will be fdefinedp at run time
;	GET indicator default
;	PUTPROP value indicator
;	DWIMIFY original-spec def-decoder (see below, DWIMIFY-PACKAGE-2).

(DEFUN VALIDATE-FUNCTION-SPEC (function-spec &AUX handler)
  1"Predicate for use with CHECK-ARG.  Returns non-nil if FUNCTION-SPEC really is one.
  The value is the type of function spec (T for a symbol)."*
  (COND ((ATOM function-spec)
	 (SYMBOLP function-spec))
	((AND (SYMBOLP (CAR function-spec))
	      (SETQ handler (GET (CAR function-spec) 'FUNCTION-SPEC-HANDLER))
	      (FUNCALL handler 'VALIDATE-FUNCTION-SPEC function-spec))
	 (CAR function-spec))))

;;  3/17/89 DNG - Original version, created to avoid duplication of code.
(DEFUN INVALID-FUNCTION-SPEC (FUNCTION-SPEC)
  (FERROR 'SYS:INVALID-FUNCTION-SPEC
	  "The function spec ~S is invalid." FUNCTION-SPEC))
(DEFPROP INVALID-FUNCTION-SPEC T :ERROR-REPORTER)

;; Is a function specifier meaningful?  A generalization of FBOUNDP.
(DEFUN FDEFINEDP (function-spec &AUX handler)
  1"Returns non-nil if the function spec is meaningful , i.e. if it is
  associated with a function object."*
  ;; Then perform type-dependent code
  (COND ((SYMBOLP function-spec) (FBOUNDP function-spec))
	((AND (CONSP function-spec)
	      (SETQ handler (GET (CAR function-spec) 'FUNCTION-SPEC-HANDLER)))
	 (FUNCALL handler 'FDEFINEDP function-spec))
	(T (INVALID-FUNCTION-SPEC FUNCTION-SPEC))))

;; Get the definition of a function specifier.  Generalized SYMBOL-FUNCTION.
(DEFUN FDEFINITION (function-spec &AUX handler)
  1"Returns the function object associated with a function spec"*
  
    ;; First, validate the function spec.
  (SETQ function-spec (DWIMIFY-ARG-PACKAGE function-spec 'FUNCTION-SPEC))
  
  (COND ((SYMBOLP function-spec) (SYMBOL-FUNCTION function-spec))
	((AND (CONSP function-spec)
	      (SETQ handler (GET (CAR function-spec) 'FUNCTION-SPEC-HANDLER)))
	 (FUNCALL handler 'FDEFINITION function-spec))
	(T (INVALID-FUNCTION-SPEC FUNCTION-SPEC))))

(MAKE-OBSOLETE FDEFINEDP-AND-FDEFINITION FDEFINITION-SAFE)
(DEFUN FDEFINEDP-AND-FDEFINITION (function-spec &AUX handler)
  "Returns whether the FUNCTION-SPEC is defined, and its definition if so.
The first value is T or NIL, the second is the definition if the first is T."
  ;; First, validate the function spec.
  (COND ((SYMBOLP function-spec)
	 (IF (FBOUNDP function-spec)
	     (VALUES T (SYMBOL-FUNCTION function-spec))))
	((AND (CONSP function-spec)
	      (SETQ handler (GET (CAR function-spec) 'FUNCTION-SPEC-HANDLER)))
	 (MULTIPLE-VALUE-BIND (definedp defn)
	     (FUNCALL handler 'FDEFINEDP function-spec)
	   (IF definedp
	       (VALUES T (OR defn (FDEFINITION function-spec))))))
	(T (INVALID-FUNCTION-SPEC FUNCTION-SPEC))))

(defmacro @define (&rest ignore) nil)


;1; this function appears in the microcode support vector. It still takes the*
;1; arguments in either order.*
;this function exists mostly for easing the phaseover to the new object scheme
; (which flushes the self argument to the named-structure handler, and uses instead
; a free reference to the variable self).
(defun named-structure-invoke (operation structure &rest args)
1  ;; this function used to take its first two arguments in the other order.
  ;; we are committed to supporting the old argument order indefinitely.*
  (if (arrayp operation)
      (psetq operation structure structure operation))
  (check-arg operation symbolp "a symbol")
  (check-arg structure arrayp "an array")
  (let* ((self structure)
	 (c (if (array-has-leader-p self)
		(array-leader self 1)
		(aref self 0))))
    (when (symbolp c)
      (setq c (get c 'named-structure-invoke)))
    (cond ((null c) nil)
	  ((typep c 'closure)			;if a closure, assume knows about self
	   (APPLY c operation args))
	  (t (APPLY c operation self args)))))	;flush the self arg
;when the phaseover is made (if ever).


(defvar inhibit-fdefine-warnings nil
  1"t turns off warnings of redefining function in different file.
  :JUST-WARN turns off queries, leaving just warnings."*)

(defprop encapsulation "encapsulation" definition-type-name)

;default handler called by function-spec-handlers to do functions they don't
;handle specially.
;;  3/17/89 DNG Updated GET operation to support a default value.
(defun function-spec-default-handler (function function-spec arg1 arg2)
  "This subroutine handles various operations for other function spec handlers."
  (CASE function
    (function-parent nil)			;default is no embedding in other definitions
    (compiler-fdefinedp nil)			;default is no remembering of compiled definitions
    (dwimify nil)
    (get (with-stack-list (key function-spec arg1)
	   (gethash key function-spec-hash-table arg2)))
    (putprop (let ((default-cons-area background-cons-area)
		   (area (%area-number function-spec)))
	       (if (or (area-temporary-p area)
		       (= area pdl-area))
		   (setq function-spec (copy-tree function-spec)))
	       (puthash (list function-spec arg2) arg1 function-spec-hash-table)
	       ))
    (push-property
     (function-spec-push-property-1 arg1 function-spec arg2))
    (otherwise (ferror nil "~s is not implemented by the function spec ~s"
		       function function-spec))))

(DEFUN FDEFINITION-SAFE (FUNCTION-SPEC &OPTIONAL UNENCAPSULATE-P DEBUG-INFO-P)
  1"Returns the function definition of a function spec.
If it is not defined, returns NIL without signalling an error.
With a non-NIL second argument, returns the definition of the
unencapsulated function spec.  With a non-nil third argument,
returns the function's debugging info as the second value."*
  ;;  6/27/85 DNG - Original version.
  ;;  2/13/87 CLM - Fix to return definition of unencapsulated function spec
  ;;                when UNENCAPSULATE-P is T.
  (DECLARE (OPTIMIZE (SPEED 3) (SAFETY 0)))
  (PROG ( FUNCTION-DEF HANDLER )
     TOP
	(SETQ FUNCTION-DEF
	      (COND ((SYMBOLP FUNCTION-SPEC)
		     (AND (FBOUNDP FUNCTION-SPEC)
			  (SYMBOL-FUNCTION FUNCTION-SPEC)))
		    ((AND (CONSP FUNCTION-SPEC)
			  (SYMBOLP (CAR FUNCTION-SPEC))
			  (SETQ HANDLER (GET (CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER)))
		     (MULTIPLE-VALUE-BIND (DEFINEDP DEFN)
			 (FUNCALL HANDLER 'FDEFINEDP FUNCTION-SPEC)
		       (AND DEFINEDP
			    (OR DEFN
				(FUNCALL HANDLER 'FDEFINITION FUNCTION-SPEC)))
		       ))
		    (T (RETURN NIL))))
	(IF (OR (SYMBOLP FUNCTION-DEF)
		(AND (NOT UNENCAPSULATE-P)
		     (NOT DEBUG-INFO-P))
		(AND (EQ UNENCAPSULATE-P 'MACRO) ; called from DECLARED-DEFINITION 
		     (OR (ATOM FUNCTION-DEF)
			 (EQ (CAR FUNCTION-DEF) 'MACRO))) )
	    (RETURN FUNCTION-DEF)
	  ;; Else, look for possible encapsulations.
	  (LET* (( DEBUG-INFO (GET-DEBUG-INFO-STRUCT FUNCTION-DEF))
		 TEM )
	    (COND ((AND UNENCAPSULATE-P
			(SETQ TEM (GET-DEBUG-INFO-FIELD DEBUG-INFO 'ENCAPSULATED-DEFINITION)))
		   (SETQ FUNCTION-SPEC (CAR TEM))
		   (GO TOP))
		  (DEBUG-INFO-P (RETURN (VALUES FUNCTION-DEF DEBUG-INFO)))
		  (T (RETURN FUNCTION-DEF)) ) ) ) ) )

;; (:property symbol property) refers to (get symbol property).
;; this has to be defined with a separate defprop for reasons which should be obvious.
(defprop :property property-function-spec-handler function-spec-handler)
(defun property-function-spec-handler (function function-spec &optional arg1 arg2)
  (let ((symbol (second function-spec))
	(indicator (third function-spec)))
    (if (not (and (= (length function-spec) 3) (symbolp symbol)))
	(unless (eq function 'validate-function-spec)
	  (invalid-function-spec function-spec))
	(CASE function
	  (validate-function-spec t)
	  (fdefine ;;(putprop symbol arg1 indicator)	; jlm 4/11/89
		   (setf (get symbol indicator) arg1))
	  ((fdefinition fdefinedp) (get symbol indicator))
	  (fdefinition-location (locf (get symbol indicator)))	;not perfect, but close
	  (fundefine (remprop symbol indicator))
	  (dwimify
	   (and (symbolp indicator)
		(multiple-value-bind (new-sym dwim-p)
		    (catch 'dwimify-package
		      (map-over-lookalike-symbols
			(symbol-name indicator)
			#'(lambda (new-symbol spec original-spec dwimify-info)
			    (or (eq new-symbol (caddr spec))
				(dwimify-package-2 `(,(car spec) ,(cadr spec) ,new-symbol)
						   original-spec dwimify-info t)))
			function-spec arg1 arg2))
		  (and dwim-p new-sym))))
	  
	  (otherwise (function-spec-default-handler function function-spec arg1 arg2))))))


(Defvar FUNCTION-SPEC-HASH-TABLE (MAKE-HASH-TABLE :test 'equal :size 500.))
;;; in the meantime, and from the cold load, this remembers non symbol source files,
;;; elements are (function-spec indicator value).
(defvar cold-load-function-property-lists)

(defun function-spec-putprop (function-spec value property)
  "Put a PROPERTY property with value VALUE on FUNCTION-SPEC.
For symbols, this is just PUTPROP, but it works on any function spec."
  (if (symbolp function-spec)
      ;;(putprop function-spec value property)		; jlm 4/11/89
      (setf (get function-spec property) value)      
      (let ((hfun (and (consp function-spec)
		       (symbolp (car function-spec))
		       (get (car function-spec) 'function-spec-handler))))
	(if hfun
	    (funcall hfun 'putprop function-spec value property)
	    (invalid-function-spec function-spec)))))

(defun function-spec-push-property (function-spec value property)
  "Push VALUE onto the PROPERTY property of FUNCTION-SPEC.
like (PUSH VALUE (FUNCTION-SPEC-GET FUNCTION-SPEC PROPERTY)) but faster."
  (if (symbolp function-spec)
      ;;(putprop function-spec (cons value (get function-spec property)) property)		; jlm 4/11/89
      (setf (get function-spec property) (cons value (get function-spec property))) 
      (let ((hfun
	      (and (consp function-spec)
		   (symbolp (car function-spec))
		   (get (car function-spec) 'function-spec-handler))))
	(if hfun
	    (funcall hfun 'push-property function-spec value property)
	    (invalid-function-spec function-spec)))))

;;  3/17/89 DNG - Added optional DEFAULT argument.
(defun function-spec-get (function-spec property &optional default)
  "Get the PROPERTY property of FUNCTION-SPEC.
For symbols, this is just GET, but it works on any function spec."
  (if (symbolp function-spec)
      (get function-spec property default)
      (let ((hfun
	      (and (consp function-spec)
		   (symbolp (car function-spec))
		   (get (car function-spec) 'function-spec-handler))))
	(if hfun
	    (funcall hfun 'get function-spec property default)
	  (invalid-function-spec function-spec)))))

;;PHD 4/21/87 Replaced copy-list by copy-tree to prevent function name corruption.
(defun function-spec-push-property-1 (value &rest key)
  ;; phd 7/31/86 added copy-list of the key rest arg.
  (declare (arglist value function-spec indicator))
  (setf key (copy-tree key))
  (puthash key (cons value (gethash key function-spec-hash-table))
	   function-spec-hash-table))

(defprop function-spec-get ((function-spec-get function-spec indicator) .
			    (function-spec-putprop function-spec val indicator))
	 setf)


;; runtime support for compiled functions that use &key.

;; required keyword args are initialized to this value.
;; we compare the values against it to see which ones are missing.

(Defparameter KEYWORD-GARBAGE (list nil))

(defprop STORE-KEYARGS t :error-reporter)

1;;;given args, the list of key names and values;
;;;keykeys, the list of keywords we understand, in their order;
;;;and FIRST-KEYARG-POINTER a locative the the local cell of the first keyword;
;;;decode the ARGS and stick the values into the right slots in the frame.
;;;SPECVAR-LIST is a list of NIL for nonspecial keyword args
;;;and symbols for special ones.
;;;It runs in parallel with KEYKEYS.
;;;If there are duplicate keywords in the supplied args, all but the first are ignored.*

(DEFUN STORE-KEYARGS (ARGS KEYKEYS ALLOW-OTHER-KEYS
		      FIRST-KEYARG-POINTER &OPTIONAL SPECVAR-LIST)
  ;; First decode what was specified.
  (DO ((ARGS-LEFT ARGS (CDDR ARGS-LEFT))
       (FOUND-FLAGS 0))
      ((NULL ARGS-LEFT) found-flags)
    (LET ((KEYWORD (CAR ARGS-LEFT)))
      (DO-FOREVER
	(LET ((INDEX (POSITION KEYWORD (THE LIST KEYKEYS) :TEST #'EQ)))
	  (COND (INDEX
		 (WHEN (ZEROP (LOGAND 1 (ASH FOUND-FLAGS (- INDEX))))
		   (SETQ FOUND-FLAGS
			 (DPB 1 (BYTE 1 INDEX) FOUND-FLAGS))
		   (LET ((SPECVAR (NTH INDEX SPECVAR-LIST)))
		     (IF SPECVAR
			 (SET SPECVAR (CADR ARGS-LEFT)))
		     ;; set the local for this keyword, careful use of subprimitives.
		     (%p-store-contents (%make-pointer-offset dtp-locative first-keyarg-pointer index)
					(CADR ARGS-LEFT))))
		 (RETURN))
		(ALLOW-OTHER-KEYS (RETURN))
		((SETQ ALLOW-OTHER-KEYS
		       (GETF ARGS-LEFT :ALLOW-OTHER-KEYS))	;treat as a disembodied plist
		 (RETURN))
		;; loop if user supplies new keyword.
		((NULL (SETQ KEYWORD (CERROR :NEW-KEYWORD NIL 'SYS:UNDEFINED-KEYWORD-ARGUMENT
					     "Keyword arg keyword ~S unrecognized."
					     KEYWORD (CADR ARGS-LEFT))))
		       (RETURN))))))))

(MAKE-OBSOLETE EXTRACT-DECLARATIONS PARSE-BODY)
;1; new code ought use PARSE-BODY instead of the following*
(DEFUN EXTRACT-DECLARATIONS (body &OPTIONAL decls doc-string-too )
  1"Extract declarations and documentation string from BODY and return them.
The first value is what is left of BODY after any doc string and decls are removed.
It is BODY missing some number of its initial elements.

The second value is the list of declarations found.
Each element of a DECLARE found in body is a declaration
and goes on this list.  The argument DECLS is the initial
value of this list, and all declarations in BODY are added to that.

The third value is the doc string found in BODY, if there was one.
However, doc strings are only noticed if DOC-STRING-TOO is non-NIL."*
  (DECLARE (VALUES BODY DECLARATIONS DOC-STRING))
  (MULTIPLE-VALUE-BIND (the-body declarations-in-form doc-string)
      (PARSE-BODY body nil doc-string-too)
    (VALUES 
      the-body 
      (LET ((complete-list-of-declarations decls))
	(DOLIST (x declarations-in-form)
	  (DOLIST (y (CDR x))
	    (PUSH y complete-list-of-declarations)))
	complete-list-of-declarations)
      (WHEN doc-string-too doc-string))))


;;; (KEYWORD-EXTRACT <keylist> KEY (FOO (UGH BLETCH) BAR) (FLAG FALG) <otherwise> ...)
;;; parses a list of alternating keywords and values, <keylist>.
;;; The symbol KEY is bound internally to remaineder of the keyword list.
;;; The keywords recognized are :FOO, :BAR and UGH;  whatever follows
;;; the keyword UGH is put in the variable BLETCH, whatever follows the
;;; keyword :FOO is put in the variable FOO, and similar for BAR.
;;; The flags are :FLAG and :FALG;  if :FLAG is seen, FLAG is set to T.
;;; <otherwise> is one or more SELECTQ clauses which can be used
;;; to recognize whatever else you like, in nonstandard format.
;;; To gobble the next thing from the <keylist>, say (CAR (SETQ KEY (CDR KEY))).
(DEFMACRO KEYWORD-EXTRACT (KEYLIST KEYVAR KEYWORDS &OPTIONAL FLAGS &BODY OTHERWISE)
  "Look through KEYLIST for keywords and set some variables and flags.
KEYLIST's value should be a list of keywords, some followed by values.
KEYWORDS describes the keywords to check for.  Each element describes one keyword.
An element can be a list of a keyword and the variable to store its value in,
or just the variable to store in (the keyword has the same pname, in the keyword package).
FLAGS is like KEYWORDS except that the flags are not followed by values;
the variable is set to T if the flag is present at all.
KEYVAR is a variable used internally by the generated code, to hold
the remaining part of the list.
OTHERWISE is some SELECTQ clauses that will be executed if an element of KEYLIST
is not a recognized flag or keyword.  It can refer to KEYVAR."
  `(DO ((,KEYVAR ,KEYLIST (CDR ,KEYVAR)))
       ((NULL ,KEYVAR))
     (CASE (CAR ,KEYVAR)
       ,@(MAPCAR #'(LAMBDA (KEYWORD)
		     (COND ((ATOM KEYWORD)
			    `(,(INTERN (STRING KEYWORD) *keyword-package*)
			      (SETQ ,KEYWORD (CAR (SETQ ,KEYVAR (CDR ,KEYVAR))))))
			   (T `(,(CAR KEYWORD)
				(SETQ ,(CADR KEYWORD)
				      (CAR (SETQ ,KEYVAR (CDR ,KEYVAR))))))))
		 KEYWORDS)
       ,@(MAPCAR #'(LAMBDA (KEYWORD)
		     (COND ((ATOM KEYWORD)
			    `(,(INTERN (STRING KEYWORD) *keyword-package*)
			      (SETQ ,KEYWORD T)))
			   (T `(,(CAR KEYWORD)
				(SETQ ,(CADR KEYWORD) T)))))
		 FLAGS)
       ,@OTHERWISE
       ,@(IF (NOT (MEMBER (CAAR (LAST OTHERWISE)) '(T OTHERWISE) :TEST #'EQ))
	     `((OTHERWISE
		 (FERROR NIL "~S is not a recognized keyword" (CAR ,KEYVAR))))))))

;;; Stuff for function specs

;This is useful for sorting function specs
;; 03/16/89 clm - Integrated changes for CLOS into Kernel.
(defun FUNCTION-SPEC-LESSP (fs1 fs2)
  "Compare two function specs, approximately alphabetically."
  ;; 11/12/86 DNG - Fixed to not error on :LOCATION specs.
  ;;  7/22/87 DNG - Adapted for Documenter by fixing for :INTERNAL function specs. [SPR 5932]
  ;;  8/15/88 DNG - Update to not error on CLOS method names.
  ;; 12/12/88 DNG - Put the Documenter version of this back into the kernel.
  ;;  1/13/89 DNG - Fix to not error on qualified methods.
  (declare (optimize (safety 0) (speed 3)))
  (cond ((and (symbolp fs1) (symbolp fs2)) ; most common case
	 (string< fs1 fs2))
	((and (consp fs1) (consp fs2)
	      (eq (first fs1) (first fs2)) (eq (second fs1) (second fs2)))
	 (let ((n1 (third fs1))
	       (n2 (third fs2)))
	   (cond ((numberp n1)
		  (if (numberp n2) (< n1 n2) nil))
		 ((numberp n2) t)
		 ((consp n1)
		  (if (consp n2) ; here for CLOS method specializers
		      (function-spec-lessp (car n1) (car n2))
		1    *;; here if fs1 is an unqualified method and fs2 is a qualified method.
		1    *t))
		 ((consp n2) ; here if fs1 is a qualified method and fs2 is an unqualified method.
		  nil)
		 (t (string< n1 n2)))))
	((consp fs1)
	 (function-spec-lessp (if (locativep (second fs1)) (first fs1) (second fs1))
			      fs2))
	((consp fs2)
	 (or (eq fs1 (second fs2))
	     (function-spec-lessp fs1 (if (locativep (second fs2)) (first fs2) (second fs2)))))
	(t (string< fs1 fs2))))

(DEFUN FUNDEFINE (FUNCTION-SPEC)
  "Makes FUNCTION-SPEC not have a function definition."
  ;; First, validate the function spec and determine its type
  
  (SETQ FUNCTION-SPEC (DWIMIFY-ARG-PACKAGE FUNCTION-SPEC 'FUNCTION-SPEC))
  
  (IF (SYMBOLP FUNCTION-SPEC) (FMAKUNBOUND FUNCTION-SPEC)
      (FUNCALL (GET (CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER) 'FUNDEFINE FUNCTION-SPEC)))

(DEFUN FDEFINITION-LOCATION (FUNCTION-SPEC &AUX HANDLER)
  "Returns a locative pointer to the cell containing FUNCTION-SPEC's definition."
  ;; First, validate the function spec and determine its type
  (COND ((SYMBOLP FUNCTION-SPEC) (LOCF (SYMBOL-FUNCTION FUNCTION-SPEC)))
	((AND (CONSP FUNCTION-SPEC)
	      (SETQ HANDLER (GET (CAR FUNCTION-SPEC) 'FUNCTION-SPEC-HANDLER)))
	 (FUNCALL HANDLER 'FDEFINITION-LOCATION FUNCTION-SPEC))
	(T (INVALID-FUNCTION-SPEC FUNCTION-SPEC))))

(Defun FUNCTION-PARENT (function-spec &AUX def tem)
  
  1"Returns NIL or the name of another definition which has the same source code.
The second value is the type of that definition (which can be NIL).
This is used for things like internal functions, methods automatically
created by a defflavor, and macros automatically created by a defstruct."*
  (DECLARE (VALUES name type))
  (COND ((AND (FDEFINEDP function-spec)
	      (SETQ tem (GET-DEBUG-INFO-FIELD
			  (GET-DEBUG-INFO-STRUCT 
			    (SETQ def (FDEFINITION function-spec)))
			  :FUNCTION-PARENT))
	      ;; Don't get confused by circular function-parent pointers.
	      (NOT (EQUAL tem function-spec)))
	 (VALUES (CAR tem) (CADR tem)))
	((AND (CONSP def) (EQ (CAR def) 'MACRO) (SYMBOLP (CDR def))	;for DEFSTRUCT
	      (SETQ def (GET (CDR def) 'MACROEXPANDER-FUNCTION-PARENT)))
	 (FUNCALL def function-spec))
	((CONSP function-spec)
	 (FUNCALL (GET (CAR function-spec) 'function-spec-handler)
		  'FUNCTION-PARENT FUNCTION-SPEC))))

;; (:LOCATION locative-or-list-pointer) refers to the CDR of the pointer.
;; This is for pointing at an arbitrary place which there is no special
;; way to describe.
1;; 12/29/88 DNG - Don't record source file name for locatives pointing into 
;;*		1the stack (in order to avoid wasting space storing useless information).*
;;  03/16/89 clm - Integrated above change into Kernel for CLOS.
(DEFPROP :LOCATION LOCATION-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER)
(DEFUN LOCATION-FUNCTION-SPEC-HANDLER (FUNCTION FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
  (LET ((LOC (SECOND FUNCTION-SPEC)))
    (IF (NOT (AND (= (LENGTH FUNCTION-SPEC) 2)
		  (OR (= (%DATA-TYPE LOC) DTP-LOCATIVE)
		      (= (%DATA-TYPE LOC) DTP-LIST))))
	(UNLESS (EQ FUNCTION 'VALIDATE-FUNCTION-SPEC)
	  (INVALID-FUNCTION-SPEC FUNCTION-SPEC))
      (CASE FUNCTION
	(VALIDATE-FUNCTION-SPEC T)
	(FDEFINE (RPLACD LOC ARG1))
	(FDEFINITION (CDR LOC))
	(FDEFINEDP (AND (/= (%P-DATA-TYPE LOC) DTP-NULL) (NOT (NULL (CDR LOC)))))
	(FDEFINITION-LOCATION LOC)
	;; FUNDEFINE could store DTP-NULL, which would only be right sometimes
	(OTHERWISE
	 (UNLESS (AND (EQ FUNCTION 'PUTPROP)
		      (EQ ARG2 ':SOURCE-FILE-NAME)
		      (EQL (%AREA-NUMBER LOC) PDL-AREA))
	   (FUNCTION-SPEC-DEFAULT-HANDLER FUNCTION FUNCTION-SPEC ARG1 ARG2)1)*)))))


(DEFUN STANDARDIZE-FUNCTION-SPEC (function-spec &OPTIONAL (errorp T))
1;Convert old Maclisp-style property function specs*
  (IF (SYMBOLP function-spec) (RETURN-FROM STANDARDIZE-FUNCTION-SPEC function-spec)
      (AND (CONSP function-spec)
	   (= (LENGTH function-spec) 2)
	   (SYMBOLP (CAR function-spec))
	   (NOT (GET (CAR function-spec) 'FUNCTION-SPEC-HANDLER))
	   (SETQ function-spec (CONS :PROPERTY function-spec))))
  (OR (NOT errorp)
      (VALIDATE-FUNCTION-SPEC function-spec)
      (FERROR NIL "~S is not a valid function spec." function-spec))
  function-spec)

(DEFUN UNDEFUN (FUNCTION-SPEC &AUX TEM)
  "Restore the saved previous function definition of a function spec."
  
  (SETQ FUNCTION-SPEC (DWIMIFY-ARG-PACKAGE FUNCTION-SPEC 'FUNCTION-SPEC))
  
  (SETQ TEM (FUNCTION-SPEC-GET FUNCTION-SPEC :PREVIOUS-DEFINITION))
  (COND (TEM
	 (FDEFINE FUNCTION-SPEC TEM T T))
	((Y-OR-N-P  "~S has no previous definition.  Undefine it? "  FUNCTION-SPEC)
	 (FUNDEFINE FUNCTION-SPEC))))

(defmacro inhibit-style-warnings (body)
  1"inhibit style warnings from compilation of body."*
  body)

1;; (:INTERNAL parent-function index) refers to the index'th
;; broken-off lambda in the parent function.
;; (:INTERNAL parent-function symbol) refers to a named
;; broken-off lambda in the parent function.
;; parent-function is normally a function-spec, but it may also be a FEF.
;; Note that VALIDATE-FUNCTION-SPEC for :INTERNAL returns NIL if the
;; function-spec itself is malformed, however if the spec is well-formed
;; but the parent doesn't have internal functions, an error is signalled
;; giving a detailed explanation.*
(DEFPROP :INTERNAL INTERNAL-FUNCTION-SPEC-HANDLER FUNCTION-SPEC-HANDLER)
(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))))))))

;;  4/11/89 DNG - Added handling of CLOSURE-NAMED-LAMBDA.
(DEFUN LAMBDA-EXP-ARGS-AND-BODY (lambda-exp)
  "Return a list containing the arglist and body of LAMBDA-EXP.
This is a list whose car is the arglist and whose cdr is the body."
  (IF (MEMBER (CAR lambda-exp) '( NAMED-LAMBDA NAMED-SUBST ZLC:NAMED-LAMBDA 
				 ZLC:NAMED-SUBST CLOSURE-NAMED-LAMBDA) :TEST #'EQ)
      (CDDR lambda-exp)
      (CDR lambda-exp)))


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