;;;  -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*-

;; 			      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) 1989 Texas Instruments Incorporated. All rights reserved.

;;;;   *-----------------------------------------------------------*
;;;;   |	   --  TI Explorer Lisp Compiler  --		   |
;;;;   |  This file contains pass 1 handlers and optimizers for    |
;;;;   |  special forms used in CLOS or its implementation.        |
;;;;   *-----------------------------------------------------------*

;;  3/16/89 DNG - This file created from pieces of "TICLOS;OPTIMIZE".


(ADD-POST-OPTIMIZER TICLOS:SLOT-VALUE SLOT-VALUE-OPT TICLOS:STANDARD-INSTANCE-ACCESS)
;; This is needed for when the class of the object can't be determined until after pass 1.
(DEFUN SLOT-VALUE-OPT (FORM)
  ;;  5/09/88 DNG - Original.
  ;;  6/09/88 PHD - Commented out to avoid optimizing when OPTIMIZE-SLOT-VALUE 
  ;;		explicitly chose to not optimize.
  ;;  8/15/88 DNG - Reinstated, but call OPTIMIZE-SLOT-VALUE instead of doing 
  ;;		the transformation directly.
  ;; 10/04/88 DNG - Pass environment to CLASS-NAMED.
  ;;  4/20/89 DNG - Optimize other predefined metaclasses besides STANDARD-CLASS.
  (LET* ((ARG (SECOND FORM))
	 (CLASS (TYPE-OF-EXPRESSION ARG))
	 CLASS-OBJECT)
    (IF (AND (= (LENGTH FORM) 3)
	     (NOT (EQ CLASS 'T))
	     (SETQ CLASS-OBJECT (TICLOS::CLASS-NAMED CLASS T *LOCAL-ENVIRONMENT*))
	     ;; Don't optimize user-defined metaclasses because we can't be sure that 
	     ;; the user-defined optimizer will return a form suitable for pass 2.
	     (MEMBER (TICLOS:CLASS-NAME (TICLOS:CLASS-OF CLASS-OBJECT))
		     'TICLOS:(STANDARD-CLASS FLAVOR-CLASS HYBRID-CLASS FUNCALLABLE-STANDARD-CLASS)))
	(TICLOS:OPTIMIZE-SLOT-VALUE CLASS-OBJECT FORM)
      FORM)))

(DEFUN STD-IVAR-OPT (FORM) ; optimize (STANDARD-INSTANCE-ACCESS instance slot-name)
  ;;  5/09/88 DNG - Original.
  ;;  5/10/88 DNG - Use TICLOS:TYPE-NAME instead of ENSURE-CLASS-NAME .
  ;;  4/25/89 DNG - Watch out for class T.
  ;;  4/28/89 DNG - Add handling for THE forms. 
  (LET ((OBJECT-ARG (SECOND FORM))
	(SLOT-ARG (THIRD FORM))
	OBJECT-VAR MAP-VAR)
    (WHEN (EQ (CAR-SAFE OBJECT-ARG) 'THE-EXPR)
      (SETQ OBJECT-ARG (EXPR-FORM OBJECT-ARG)))
    (IF (AND (QUOTEP SLOT-ARG)			; slot name is a constant
	     (NULL (CDDDR FORM))		; right number of arguments
	     (EQ (CAR-SAFE OBJECT-ARG) 'LOCAL-REF)
	     (SETQ MAP-VAR (GETF (VAR-DECLARATIONS (SETQ OBJECT-VAR (SECOND OBJECT-ARG)))
				 'MAPPING-TABLE)) )
	;; Can optimize to %STANDARD-INSTANCE-REF
	(LET ((CLASS-NAME (TICLOS:TYPE-NAME (VAR-DATA-TYPE OBJECT-VAR))))
	  (IF (EQ CLASS-NAME 'T)
	      FORM
	    (IF (AND (EQ (VAR-COMPILAND OBJECT-VAR) *CURRENT-COMPILAND*)
		     (EQ (VAR-COMPILAND MAP-VAR) *CURRENT-COMPILAND*))
		`(%STANDARD-INSTANCE-REF ,OBJECT-ARG ,(VAR-LAP-ADDRESS MAP-VAR)
					 ,CLASS-NAME ,(SECOND SLOT-ARG))
	      (WITH-STACK-LIST* (VARS MAP-VAR VARS)
		(P1 `(LET ((.OBJECT. ,(MARK-P1-DONE OBJECT-ARG))
			   (.MAP. ,(VAR-NAME MAP-VAR)))
		       (%STANDARD-INSTANCE-REF .OBJECT. .MAP.
					       ,CLASS-NAME ,(SECOND SLOT-ARG)) )
		    )))))
      FORM)))
(ADD-POST-OPTIMIZER TICLOS:STANDARD-INSTANCE-ACCESS STD-IVAR-OPT)

(DEFUN (:PROPERTY %STANDARD-INSTANCE-REF P1) (FORM)
  ;;  4/17/89 DNG - Add update of USED-VAR-SET for consistency with P1ACCESSOR.
  (LET ((P1VALUE 'SINGLE-VALUE))
    (PROG1 (LIST* (FIRST FORM) (P1 (SECOND FORM)) (P1 (THIRD FORM)) (CDDDR FORM))
	   (SETF USED-VAR-SET (LOGIOR USED-VAR-SET DATA-ALTERATION-BIT)))))

(DEF %SET-STANDARD-INSTANCE-REF)
(DEFPROP %SET-STANDARD-INSTANCE-REF (VALUE OBJECT MAPPING-TABLE &QUOTE CLASS-NAME SLOT-NAME)
	 ARGLIST)
(DEFUN (:PROPERTY %SET-STANDARD-INSTANCE-REF P1) (FORM)
  `(SETQ ,(P1 `(%STANDARD-INSTANCE-REF . ,(CDDR FORM)))
	 ,(P1V (SECOND FORM))))

(DEFUN SETF-STD-IVAR-OPT (FORM)
  ;; optimize (FUNCALL #'(SETF STANDARD-INSTANCE-ACCESS) value instance slot-name)
  ;;  5/10/88 DNG - Original.
  ;;  2/27/89 DNG - Add handling for FLAVOR-INSTANCE-ACCESS .
  ;;  3/3/89 DNG - Add optimization for calls to #'(SETF SLOT-VALUE) where the 
  ;;		class of the object was not apparent until after other optimizations 
  ;;		were done [particularly the one in SETQ-OPT].
  ;;  3/8/89 DNG - Permit optimizing HYBRID-CLASS.
  ;; 4/22/89 DNG - Fix to not try to reference slots in class T.
  ;;  4/28/89 DNG - Add handling for THE forms. 
  (IF (AND (OR (EQUAL (SECOND FORM) '(FUNCTION (SETF TICLOS:STANDARD-INSTANCE-ACCESS)))
	       (EQUAL (SECOND FORM) '(FUNCTION (SETF ticlos:flavor-instance-access))))
	   (= (LENGTH FORM) 5))
      (LET ((OBJECT-ARG (FOURTH FORM))
	    (SLOT-ARG (FIFTH FORM))
	    OBJECT-VAR MAP-VAR)
	(WHEN (EQ (CAR-SAFE OBJECT-ARG) 'THE-EXPR)
	  (SETQ OBJECT-ARG (EXPR-FORM OBJECT-ARG)))
	(IF (AND (QUOTEP SLOT-ARG)		; slot name is a constant
		 (EQ (CAR-SAFE OBJECT-ARG) 'LOCAL-REF)
		 (SETQ MAP-VAR (GETF (VAR-DECLARATIONS (SETQ OBJECT-VAR (SECOND OBJECT-ARG)))
				     'MAPPING-TABLE)) )
	    ;; Can optimize to %STANDARD-INSTANCE-REF
	    (LET ((CLASS-NAME (TICLOS:TYPE-NAME (VAR-DATA-TYPE OBJECT-VAR))))
	      (IF (EQ CLASS-NAME 'T)
		  FORM
		(IF (AND (EQ (VAR-COMPILAND OBJECT-VAR) *CURRENT-COMPILAND*)
			 (EQ (VAR-COMPILAND MAP-VAR) *CURRENT-COMPILAND*))
		    `(SETQ (%STANDARD-INSTANCE-REF ,OBJECT-ARG ,(VAR-LAP-ADDRESS MAP-VAR)
						   ,CLASS-NAME ,(SECOND SLOT-ARG))
			   ,(THIRD FORM))
		  (WITH-STACK-LIST* (VARS MAP-VAR VARS)
		    (P1 `(LET ((.OBJECT. ,(MARK-P1-DONE OBJECT-ARG))
			       (.MAP. ,(VAR-NAME MAP-VAR)))
			   ;; Can't use SETQ here because the pass 1 handler for SETQ won't accept it.
			   (%SET-STANDARD-INSTANCE-REF ,(MARK-P1-DONE (THIRD FORM))
						       .OBJECT. .MAP. ,CLASS-NAME ,(SECOND SLOT-ARG))
			   ))))))
	  (IF (EQUAL (SECOND FORM) '(FUNCTION (SETF ticlos:flavor-instance-access)))
	      ;; use equivalent of inline expansion of SET-IN-INSTANCE
	      (P1 (LET ((VALUE (GENSYM)))
		    `(LET ((,VALUE ,(MARK-P1-DONE (THIRD FORM))))
		       (SYS:SETCDR ,(MARK-P1-DONE `(LOCATE-IN-INSTANCE ,OBJECT-ARG ,SLOT-ARG)) ,VALUE))))
	    FORM)))
    (IF (EQUAL (SECOND FORM) '(FUNCTION (SETF TICLOS:SLOT-VALUE)))
	(LET* ((OBJECT-ARG (FOURTH FORM))
	       (CLASS (TYPE-OF-EXPRESSION OBJECT-ARG))
	       CLASS-OBJECT)
	  (IF (AND (= (LENGTH FORM) 5)
		   (NOT (EQ CLASS 'T))
		   (SETQ CLASS-OBJECT (TICLOS::CLASS-NAMED CLASS T *LOCAL-ENVIRONMENT*))
		   ;; Do this only for STANDARD-CLASS because it is the only one that we 
		   ;; know will return a form suitable for pass 2.
		   (MEMBER (TICLOS:CLASS-NAME (TICLOS:CLASS-OF CLASS-OBJECT))
			   '(TICLOS:STANDARD-CLASS TICLOS:HYBRID-CLASS)) )
	      (TICLOS:OPTIMIZE-SETF-SLOT-VALUE CLASS-OBJECT FORM)
	    FORM))
      FORM)))

(ADD-POST-OPTIMIZER FUNCALL SETF-STD-IVAR-OPT)

(ADD-POST-OPTIMIZER TICLOS:flavor-instance-access flavor-ivar-opt) ; push this first to be tried last
(defun flavor-ivar-opt (form)
  ;; Expand FLAVOR-INSTANCE-ACCESS the same as SYMEVAL-IN-INSTANCE.
  ;;  2/27/89 DNG - Original.
  `(cdr (locate-in-instance . ,(rest form))))
(ADD-POST-OPTIMIZER TICLOS:flavor-instance-access STD-IVAR-OPT) ; try this one first


;;;  Meta-class driven slot-value optimization

(defmacro ticlos:DEFINE-INSTANCE-ACCESS-OPTIMIZATION (function-spec lambda-list class-arg optimizer)
  "Call function OPTIMIZER to optimize calls to FUNCTION-SPEC when the number 
of arguments matches LAMBDA-LIST and the class of argument CLASS-ARG is known.
OPTIMIZER is passed two arguments: the class object and the form, and returns
the optimized form."
  ;;  5/10/88 DNG
  ;; 10/04/88 DNG - Pass environment to CLASS-NAMED.
  (declare (symbol class-arg) (list lambda-list))
  (check-type function-spec (satisfies validate-function-spec) "a function spec")
  (check-type optimizer (satisfies validate-function-spec) "a function spec")
  (let* ((n (position class-arg lambda-list))
	 (check-num (multiple-value-bind (nmin nmax rest-arg)
			(si::args-desc-using-lambda-list lambda-list)
		      (when (or (null n) (>= n nmin))
			(error "~S is not a required argument in ~S" class-arg lambda-list))
		      ;; generate code to check the number of arguments
		      `(lambda (args)
			 ,(if rest-arg
			      (if (> nmin 0)
				  `(>= (length args) ,nmin)
				`(progn args t))
			    (if (> nmin 0)
				(if (= nmin nmax)
				    `(= (length args) ,nmax)
				  `(<= ,nmin (length args) ,nmax))
			      `(<= (length args) ,nmax)))))))
    (if (symbolp function-spec)
	(let ((optimizer-name (intern (string-append function-spec "/" "OPTIMIZER")
				      (symbol-package function-spec))))
	  `(progn (defun ,optimizer-name (form)
		    (let ((arg (nth ,(+ n 1) form))
			  var class-name class-object)
		      (if (and (symbolp arg)
			       (,check-num (cdr form))
			       (setq var (lookup-var arg))
			       (neq (setq class-name (var-data-type var))
				    't)
			       (setq class-object
				     (ticlos:class-named class-name t *local-environment*)))
			  (funcall (function ,optimizer) class-object form)
			form)))
		  (add-optimizer ,function-spec ,optimizer-name)
		  ))
      (let ((optimizer-name (intern (string-append (first function-spec) "/"
						   (second function-spec) "/" "OPTIMIZER")
				    (symbol-package (second function-spec)))))
	`(progn (defun ,optimizer-name (form)
		  (if (and (equal (second form) '(function ,function-spec))
			   (,check-num (cddr form)))
		      (let ((arg (nth ,(+ n 2) form))
			    var class-name class-object)
			(if (and (symbolp arg)
				 (setq var (lookup-var arg))
				 (neq (setq class-name (var-data-type var))
				      't)
				 (setq class-object
				       (ticlos:class-named class-name t *local-environment*)))
			    (funcall (function ,optimizer) class-object form)
			  form))
		    form))
		(add-optimizer funcall ,optimizer-name)
		)))))

(ADD-STYLE-CHECKER TICLOS:NEXT-METHOD-P IN-METHOD-ONLY)
(ADD-STYLE-CHECKER TICLOS:CALL-NEXT-METHOD IN-METHOD-ONLY)
(DEFUN IN-METHOD-ONLY (FORM)
  ;;  8/18/88 DNG - Original.
  (UNLESS (FBOUNDP (FIRST FORM))
    (WARN 'IN-METHOD-ONLY ':IMPOSSIBLE
	  "~S can only be used within a method body." (FIRST FORM))))



;; To recognize this as having no side-effects:
(defprop %class-description p1simple p1) 

(add-optimizer ticlos::class-named class-named-opt)
(add-optimizer ticlos::method-named class-named-opt)
;; This is to avoid writing to the object file the call to CLASS-NAMED which 
;; is at the end of the expansion of DEFCLASS or the call to METHOD-NAMED at 
;; the end of the DEFMETHOD expansion.  [Or maybe it might be better to handle 
;; this in QC-FILE-FASD-FORM instead.] -- DNG 8/31/88
(defun class-named-opt (form)
  (if (and (eq P1VALUE 'TOP-LEVEL-FORM)
	   qc-file-in-progress
	   (not qc-file-load-flag)
	   (= (length form) 2))
      ;; result value not needed, so don't call the function.
      (second form)
    form))

(add-post-optimizer ticlos::make-generic-function make-generic-opt)
(defun make-generic-opt (form)
  (if (every #'quotep (the list (rest form)))
      (p1 `(function ,(apply #'ticlos::create-generic-function
			     (mapcar #'second (rest form)))))
    form))

(add-optimizer ticlos:generic-function g-f-opt)
(defun g-f-opt (form)
   ;; 11/17/88 DNG - Original.
  (if (member p1value '(downward-only d-inds) :test #'eq)
       ;; This function is only being called, so there is no possibility of 
       ;; the user altering it after it is created.  Optimize to do all the 
       ;; work at load time instead of run time.
      (let ((temp (gensym)))
	 `(ticlos:generic-flet ((,temp . ,(cdr form))) #',temp))
    form))

;; Finished except for optimization to call methods directly.

(DEFUN (:PROPERTY TICLOS:GENERIC-FLET P1) (FORM)
  ;; 11/15/88 DNG - Original, adapted from FLET handler.
  ;; 12/28/88 DNG - Pass 2nd arg of T to P1.
  (MULTIPLE-VALUE-BIND (LOCALS BINDINGS METHODS)
      (PREPARE-LOCAL-GENERIC FORM NIL)
    (OPTIMIZE-LOCAL-GENERIC
      (P1 `(LET ,BINDINGS
	     ,@METHODS
	     (FLET-INTERNAL ,(MAPCAR #'(LAMBDA (VAR DEF)
					 (LIST (CAR DEF) VAR))
				     LOCALS (SECOND FORM))
			    . ,(CDDR FORM)))
	  ;; Don't let LET-OPT change anything before OPTIMIZE-LOCAL-GENERIC has a chance first.
	  T))))

(DEFUN (:PROPERTY TICLOS:GENERIC-LABELS P1) (FORM)
  ;; 11/17/88 DNG - Original.
  ;; 12/28/88 DNG - Pass 2nd arg of T to P1.
  ;; The generic functions can't actually call each other, but the methods can 
  ;; call the local generic functions.  So instead of being like LABELS, this 
  ;; is actually implemented like GENERIC-FLET except that the method 
  ;; definitions are placed inside the FLET-INTERNAL form instead of preceding it.
  (MULTIPLE-VALUE-BIND (LOCALS BINDINGS METHODS)
      (PREPARE-LOCAL-GENERIC FORM T)
    (OPTIMIZE-LOCAL-GENERIC
      (P1 `(LET ,BINDINGS
	     (FLET-INTERNAL ,(MAPCAR #'(LAMBDA (VAR DEF)
					 (LIST (CAR DEF) VAR))
				     LOCALS (SECOND FORM))
			    ,@METHODS
			    (LOCALLY . ,(CDDR FORM))))
	  ;; Don't let LET-OPT change anything before OPTIMIZE-LOCAL-GENERIC has a chance first.
	  T))))

(DEFUN PREPARE-LOCAL-GENERIC (FORM &OPTIONAL LABELS)
  (DECLARE (VALUES LOCALS BINDINGS BODY))
   ;; Used by the pass 1 handlers for GENERIC-FLET and GENERIC-LABELS.
   ;; 11/17/88 DNG - Original.
  ;; 12/29/88 DNG - Pass :ENVIRONMENT option to CREATE-GENERIC-FUNCTION .
   ;;  1/18/89 DNG - Add use of ADDITIONAL-FORMS.
  (LET* ((LOCALS '()) ; names of local variables that hold the generic functions.
	  (BINDINGS '()) ; list of bindings for the LET
	  (BODY '())) ; ADD-METHOD forms to be inserted in the body of the LET
    (DECLARE (LIST LOCALS BINDINGS BODY))
    (DOLIST (X (SECOND FORM))
      (LET ((VARNAME (LOCAL-FUNCTION-SLOT-NAME X)))
	 (multiple-value-bind (option-list method-list)
	     (ticlos:process-generic-options (CDDR X))
	   (MULTIPLE-VALUE-BIND (EXP GFUN)
	       (apply #'ticlos::create-generic-function
		       :name (FIRST X) :lambda-list (SECOND X)
		        :environment *local-environment*
		       (mapcar #'sys:*eval option-list))
	     (PUSH `(,VARNAME (GENERIC-FLET-FUNCTION ,EXP ,LABELS ,GFUN)) BINDINGS)
	     (PUSH VARNAME LOCALS)
	     (dolist (m method-list)
	        (WARN-ON-ERRORS ('PREPARE-LOCAL-GENERIC "Error in generic function option ~S" `(:method . ,m))
		  (multiple-value-bind (qualifiers specializers function lambda-list ignore 
					ignore additional-forms)
		      (ticlos:parse-method m (FIRST X) *LOCAL-ENVIRONMENT*)
		    (comment ; this approach might be useful if we wanted to optimize to call the methods directly.
		      (LET ((MVAR (GENSYM)))
			(PUSH `(,MVAR (FUNCTION ,FUNCTION)) BINDINGS)
			(PUSH `(ticlos:add-method ,VARNAME (ticlos:make-method ',qualifiers ',specializers
									       ,MVAR ',lambda-list))
			      BODY)))
		    (setq body (cons `(ticlos:add-method
					,VARNAME
					(ticlos:make-method ',qualifiers ',specializers
							    (FUNCTION ,FUNCTION) ',lambda-list))
				     (nconc additional-forms body)))
		    ;; This is to get a compile-time warning if there is an arglist mismatch.
		    (ticlos:add-method GFUN (make-compile-time-method qualifiers specializers
								      FUNCTION lambda-list *LOCAL-ENVIRONMENT*))
		    )))))))
    (VALUES (NREVERSE LOCALS) (NREVERSE BINDINGS) (NREVERSE BODY))))

(DEFUN OPTIMIZE-LOCAL-GENERIC (THE-FORM)
  ;; Used by the pass 1 handlers for GENERIC-FLET and GENERIC-LABELS.
  ;; 11/17/88 DNG - Original.
  ;; 12/28/88 DNG - Fix to pass :GENERIC-FUNCTION-CLASS option to MAKE-GENERIC-FUNCTION.
  ;;  5/02/89 DNG - Update to check %LET instead of LET.
  (WHEN (EQ (FIRST THE-FORM) 'THE-EXPR)
    (LET (LET-FORM NEW-BODY (ADOPTED '()))
      (CASE (FIRST (EXPR-FORM THE-FORM))
	((%LET %LET*) (SETQ LET-FORM (EXPR-FORM THE-FORM))
		      (SETQ NEW-BODY (NTHCDR 2 LET-FORM)))
	(PROGN (SETQ NEW-BODY (CDR (EXPR-FORM THE-FORM)))))
      ;; Try to optimize creation of generic functions.
      (DOLIST (V (FIRST (SECOND LET-FORM)))
	(LET ((INIT-FORM (VAR-INIT-FORM V)))
	  (WHEN (AND (CONSP INIT-FORM)
		     (EQ (FIRST INIT-FORM) 'LEXICAL-CLOSURE)
		     (> (LENGTH INIT-FORM) 3))
	    (LET ((GFUN (FIFTH INIT-FORM)))
	      (comment ; not needed yet, may be useful for optimizing to call method directly.
		(SETF (GETF (VAR-DECLARATIONS V) ':GENERIC-FUNCTION)
		      GFUN))
	      (IF (THIRD INIT-FORM)
		  ;; Ephemeral local function, can construct generic function at load time.
		  (SETF (CAR INIT-FORM) (FOURTH INIT-FORM)
			(CDR INIT-FORM) (LIST (SECOND INIT-FORM) (THIRD INIT-FORM)))
		;; Else output code to construct the generic function at run time.
		(SETF (CAR INIT-FORM) 'TICLOS:MAKE-GENERIC-FUNCTION
		      (CDR INIT-FORM) (CONS (P1 ':GENERIC-FUNCTION-CLASS)
					    (CDR (P1V (SEND GFUN :FASD-FORM))))))))))
      ;; Try to optimize installation of methods.
      (DOLIST (BODY-FORM NEW-BODY)
	(LET (INIT-FORM)
	  (IF (AND (CONSP BODY-FORM)
		   (EQ (FIRST BODY-FORM) 'TICLOS:ADD-METHOD)
		   (PROGN (SETQ INIT-FORM (SECOND BODY-FORM))	; generic function
			  (WHEN (EQ (CAR-SAFE (SECOND BODY-FORM)) 'LOCAL-REF)
			    (SETQ INIT-FORM (VAR-INIT-FORM (SECOND INIT-FORM))))
			  (EQ (CAR-SAFE INIT-FORM) 'BREAKOFF-FUNCTION)))
	      ;; Adding method to a local generic function constructed at load time.
	      (LET ((MM (THIRD BODY-FORM)) ; MAKE-METHOD form
		    COMPILAND)
		(WHEN (AND (EQ (CAR-SAFE MM) 'TICLOS:MAKE-METHOD)
			   (EQ (CAR-SAFE (FOURTH MM)) 'BREAKOFF-FUNCTION)
			   (EQL 1 (COMPILAND-USE-COUNT (SETQ COMPILAND (SECOND (FOURTH MM))))))
		  ;; Add the method at load time instead of run time.
		  (LET* ((GCOMP (SECOND INIT-FORM))	; generic function compiland
			 (GNAME (COMPILAND-FUNCTION-SPEC GCOMP))	
			 (FSPEC `(TICLOS:METHOD ,GNAME ,@(SECOND (SECOND MM)) ,(SECOND (THIRD MM)))))
		    (SETF (EXPR-FORM THE-FORM) (DELETE BODY-FORM (THE LIST (EXPR-FORM THE-FORM))
						       :TEST #'EQ :COUNT 1))
		    (DISCARD BODY-FORM)
		    ;; Attach the method compiland to its generic function compiland;
		    ;; LAP-MFEF will put the methods on COMPILER-QUEUE after finishing 
		    ;; compilation of the generic function.
		    (PUSH COMPILAND (GETF (COMPILAND-PLIST GCOMP) 'INITIAL-METHODS))
		    ;; The name is modified destructively so that the change will also affect any children.
		    (SETF (CAR (COMPILAND-FUNCTION-SPEC COMPILAND)) (CAR FSPEC))
		    (SETF (CDR (COMPILAND-FUNCTION-SPEC COMPILAND)) (CDR FSPEC))
		    (SETF (CAR (COMPILAND-FUNCTION-NAME COMPILAND)) (CAR FSPEC))
		    (SETF (CDR (COMPILAND-FUNCTION-NAME COMPILAND)) (CDR FSPEC))
		    (PUSH COMPILAND ADOPTED)
		    )))
	    (RETURN))))
      ;; This is just to shorten the local FEF lists in the debug info.
      (DO ()
	  ((OR (NULL ADOPTED)
	       (NOT (EQ (CAR ADOPTED) (CAR (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))))
	(POP ADOPTED)
	(POP (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
	(POP (COMPILAND-LOCAL-FUNCTION-MAP *CURRENT-COMPILAND*)))
      ;; Now re-optimize the LET.
      (SETF (EXPR-FORM THE-FORM) (POST-OPTIMIZE (EXPR-FORM THE-FORM)))) )
  THE-FORM)

(DEFUN (:PROPERTY GENERIC-FLET-FUNCTION P1) (FORM)
  ;; 11/16/88 DNG - Original.
  (DESTRUCTURING-BIND (IGNORE EXP LABELS GFUN) FORM
    (LET* ((FORM1 (BREAKOFF EXP T))
	   (FORM2 (LIST (IF LABELS
			      ;; Hack alert: this isn't completely correct, but for GENERIC-LABELS 	<===<<<  !!! ???
			      ;; we need to prevent run-time generation of the generic function 
			      ;; because lexical closure methods don't work yet.  -- DNG 11/17/88
			      (CAR FORM1)
			   'LEXICAL-CLOSURE)
			 (SECOND FORM1) T (CAR FORM1) GFUN)))
      FORM2)))

(defun make-compile-time-method (method-combination-identifiers
				 specializers function lambda-list &optional environment)
  (sys:make-flavor-instance (if (equal '(:combined) method-combination-identifiers)
				'ticlos:combined-method
			      'ticlos:standard-method)
			    :lambda-list lambda-list
			    :parameter-specializers
			    (loop for x in specializers
				  collect (ticlos::canonicalize-class-spec x environment))
			    :qualifiers method-combination-identifiers
			    :function function))

(defsubst initial-package-p (pkg)
  (member pkg '#,(adjoin (symbol-package 'ticlos:defclass)
			 (loop for x in sys::initial-packages
			       unless (or (string-equal (car x) "USER")
					  (null (find-package (car x))))
			       collect (find-package (car x))))
	  :test #'eq))

(add-optimizer TICLOS:WITH-ADDED-METHODS w-a-m-opt)
(defun w-a-m-opt (form)
  ;; 12/17/88 DNG - Original.
  ;;  1/18/89 DNG - Add use of ADDITIONAL-FORMS.
  (destructuring-bind (ignore (function-specifier lambda-list &rest options) &body body) form
    (unless (function-spec-p function-specifier)
      (warn 'ticlos:with-added-methods ':impossible "In ~S, ~S is not a valid function name."
	    (first form) function-specifier)
      (return-from w-a-m-opt `(locally . ,body)))
    (let ((required-args (loop for x in lambda-list
			       until (member x '(&rest &optional &key &aux))
			       unless (member x lambda-list-keywords :test #'eq)
			       collect (if (atom x) x (car x))))
	  defined generic-p temp
	  (outer-function (mark-p1-done
			    (let* ((p1value 'downward-only) exp)
			      (unless (boundp 'expression-size)	; if at top level
				(%bind (locf expression-size) 0))
			      (setq exp (p1 `(function ,function-specifier)))
			      (if (eq (car-safe exp) 'function)
				  ;; Tell QLP2-Q to not record this as a reference to an undefined function.
				  `(function ,(second exp) dont-record)
				exp)))
			  ))
      (cond ((setq temp (assoc function-specifier local-functions :test #'equal))
	     ;; Local function; we know it is defined and whether it is generic.
	     (setq generic-p (typep-structure-or-flavor (fifth (var-init (second temp)))
							'ticlos:generic-function))
	     (setq defined 't))
	    ((and (fdefinedp function-specifier)
		  (or (and (compiler:external-symbol-p function-specifier)
			   (initial-package-p (symbol-package function-specifier)))
		      (and (consp function-specifier)
			   (eq (car function-specifier) 'setf)
			   (compiler:external-symbol-p (second function-specifier))
			   (let ((p1 (get-source-file-name function-specifier 'defun))
				 (p2 (get-source-file-name 'ticlos:defclass 'defun)))
			     (and p1 p2
				  (equal (send p1 :get :systems)
					 (send p2 :get :systems)
					 ))))))
	     ;; We can assume it will always be defined.
	     (setq defined 't)
	     (setq generic-p (ticlos:generic-function-p function-specifier)))
	    (t (setq defined
		     (if (symbolp function-specifier)
			 `(fboundp ',function-specifier)
		       `(fdefinedp ',function-specifier)))
	       (setq generic-p 'unknown)))
      (if (or (eq generic-p 'nil) ; if definitely not generic
	      (block safep
		(dolist (option options t)
		  (when (eq (car-safe option) ':method)
		    (dolist (x (cdr option))
		      (when (listp x)
			(return
			  (dolist (arg (ticlos:lambda-list-specializer x))
			    (unless (consp (second arg))
			      (let ((class (ticlos:class-named (second arg)
							       t *compile-file-environment*)))
				(when (or (null class)
					  (not (null (ticlos:class-direct-subclasses class))))
				  (return-from safep nil))))))))))))
	  ;; We know that we aren't adding a method that is less specific than 
	  ;; any previous methods; this lets us do it the easy way.
	  `(ticlos:generic-labels
	     ((,function-specifier ,lambda-list
	       ,(if (= (length required-args) (length lambda-list))
		    `(:method ,required-args
			      (if ,defined
				  (funcall ,outer-function . ,required-args)
				(ticlos:no-applicable-method
				  #',function-specifier . ,required-args)))
		  `(:method (,@required-args &rest ticlos::.rest.)
			    (if ,defined
				(apply ,outer-function ,@required-args ticlos::.rest.)
			      (apply #'ticlos:no-applicable-method
				     #',function-specifier ,@required-args ticlos::.rest.))))
	       . ,options))
	     . ,body)
	;; Else have to do it the hard way.
	;; This is adapted from a combination of the GENERIC-FUNCTION macro and the 
	;; pass 1 handler for GENERIC-LABELS.
	(multiple-value-bind (option-list method-list)
	    (ticlos:process-generic-options options)
	  (let ((gf (local-function-slot-name (second form)))
		(method-forms '()))
	    (dolist (m method-list)
	      (multiple-value-bind (qualifiers specializers function lambda-list ignore ignore additional-forms)
		  (ticlos:parse-method m nil *compile-file-environment*)
		(setq method-forms
		      (cons `(ticlos:add-method
			       ,gf (ticlos:make-method ',qualifiers ',specializers
						       (function ,function) ',lambda-list))
			    (nconc additional-forms method-forms)))))
	    `(let ((,gf (ticlos:extend-generic-function :name ',function-specifier
							:lambda-list ',lambda-list
							. ,option-list)))
	       (flet-internal ((,function-specifier ,gf))
			      ,.(nreverse (the list method-forms))
			      (locally . ,body)
			      ))))
	))))

(DEFUN (:PROPERTY SYS:%GENERIC-FUNCTION-HASH-TABLE P1) (FORM)
   ;; 11/17/88 DNG - Original.
  (IF INLINE-EXPANSIONS
      ;; Generic functions can't be expanded inline.
      (THROW (SECOND (FIRST INLINE-EXPANSIONS)) ':GENERIC-FUNCTION)
    FORM))

;;  4/24/89 DNG - added the next 3 lines.
(DEFPROP CLOS:COMPUTE-APPLICABLE-METHODS LIST	FUNCTION-RESULT-TYPE)
(DEFPROP CLOS:METHOD-QUALIFIERS		LIST	FUNCTION-RESULT-TYPE)
(DEFPROP CLOS:FUNCTION-KEYWORDS		LIST	FUNCTION-RESULT-TYPE)