;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS;  Base:8; Cold-Load:T -*-

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

;;PHD 2/3/87:  added optimization support for THE. (see parse-the-in-place).
;;  8/15/88 clm - changed PUSHNEW so that any :KEY argument is applied to both
;;                the new item and to each element of the list.
;;  8/30/88 clm - fixed doc string for LOCF. 
;;  9/20/88 clm - fixed DEFSETF for cases where there is an &rest argument.  Changed
;;                to not use a temporary variable for this argument. 
;; 12/13/88 clm - fixed the SETF form for CAAAR. [spr 9108]



;; Each element of NONCONSTANT-ALIST is a list of five elements.
;; The first one is the temporary variable described.
;; The second is the number of times that variable has been seen,
;; not counting the time when its value was computed.

(eval-when (compile)
   (defmacro seo-count (x) `(cadr ,x))
   
;; The third element is the specified value expression to "substitute".
   (defmacro seo-exp (x) `(caddr ,x))
   
;; The fourth element is the temporary variable to hold this value in during execution.
   (defmacro seo-tempvar (x) `(cadddr ,x))
   
;; The fifth element points to a PROGN which contains a SETQ
;; that sets the seo-tempvar from the seo-exp.
   (defmacro seo-first-use (x) `(fifth ,x))
   
   )						;end of eval-when

(defvar seo-first-uninserted-var nil)

;; Called like SUBLIS, but makes the replacement expressions
;; be evaluated only once and in the same order as they appear in ALIST.
(defun sublis-eval-once (alist exp &optional reuse-flag sequential-flag
			 (environment *macroexpand-environment*))
  "Effectively substitute for symbols in EXP according to ALIST, preserving execution order.
Each element of ALIST describes one symbol (the car)
and what it stands for (the cdr).
We replace each symbol with the corresponding value expression,
not with straight textual substitution but so that
the value expression will be evaluated only once.

If SEQUENTIAL-FLAG is non-NIL, the value substituted for each symbol
may refer to the previous symbols substituted for.

This may require the use of temporary variables.
The first use of a symbol would be replaced by a SETQ of the tempvar
to the symbol's corresponding expression.  Later uses would be
replaced with just the tempvar.  A LET to bind the tempvars is
wrapped around the whole expression.

If REUSE-FLAG is non-NIL, the symbols themselves can be used
as their own tempvars when necessary.  Otherwise tempvars are gensymmed.

It may be necessary to expand macros in EXP in order to process it.
In this case, ENVIRONMENT is passed as the environment arg to MACROEXPAND.
It defaults to the value of *MACROEXPAND-ENVIRONMENT*, which within a macro's
expander function is bound to the environment of expansion."
  (let (constant-alist nonconstant-alist
	value-so-far)
    ;; First, divide replacements up into constant values vs nonconstants.
    ;; Order of evaluation never matters for the constants so we will
    ;; put them in with SUBLIS.
    (dolist (elt alist)
      (let ((tem (if sequential-flag
		     (sublis constant-alist (cdr elt))
		     (cdr elt))))
	(if (constantp tem)
	    (push (if (eq tem (cdr elt)) elt (cons (car elt) tem))
		  constant-alist)
	    (push (list (car elt) 0 tem nil nil)
		  nonconstant-alist))))
    ;; The nonconstants must remain in the proper order!
    (setq nonconstant-alist (nreverse nonconstant-alist))
    ;; If the only things not constant are variables,
    ;; then they are ok.
    (when (loop for elt in nonconstant-alist
		always (symbolp (seo-exp elt)))
      (dolist (elt nonconstant-alist)
	(push (cons (car elt)
		    (if sequential-flag (sublis constant-alist (seo-exp elt)) (seo-exp elt)))
	      constant-alist))
      (setq nonconstant-alist nil))
    (setq value-so-far (sublis constant-alist exp))
    (when nonconstant-alist
      ;; If the expression to be substituted in
      ;; contains any kind of branching,
      ;; we must calculate all the variables at the beginning
      ;; to avoid having the calculation be skipped by a branch.
      ;; Hairier analysis might detect certain cases
      ;; such as a variable being used before the branch, or only after a join,
      ;; but that is probably not worth thinking about.
      (if (fboundp 'compiler:cw-top-level ) ;PHD 6/20/86 added test for cw-top-level,
	  (multiple-value-bind (ignore functions-used)
	      (compiler:cw-top-level exp nil '(variable-location cond and or return return-from go
								 *catch *throw catch throw
								 do do* do-named do*-named if comment)
				     ;;9/4/85 added if (special form now.)
				     ;;8/1/86 added Comment 
				     (cadr environment))
	    (if functions-used
		(setq value-so-far `(progn ,@(mapcar 'car nonconstant-alist) ,value-so-far))))
	  (setq value-so-far `(progn ,@(mapcar 'car nonconstant-alist) ,value-so-far)))
      ;; Each nonconstant value should be inserted only once, and in correct order.
      ;; SEO-FIRST-UNINSERTED-VAR points to the first one we have not yet inserted.
      ;; All the ones before that have had temporary variables (gensyms) made.
      (let* ((seo-first-uninserted-var nonconstant-alist))
	(setq value-so-far (sublis-eval-once-1 value-so-far nonconstant-alist
					       reuse-flag sequential-flag))
	;; Now stick on evaluations of any values that weren't really used.
	(if seo-first-uninserted-var
	    (setq value-so-far
		  `(multiple-value-prog1
		     ,value-so-far
		     . ,(if sequential-flag
			    (list (sublis-eval-once-1 (caar (last nonconstant-alist))
						      nonconstant-alist
						      reuse-flag t))
			    (mapcar 'caddr seo-first-uninserted-var))))))
      ;; If a temp var is not used again after it is set,
      ;; flush the temp var from the code -- just use its value straight.
      (dolist (elt nonconstant-alist)
	(let ((tem (seo-first-use elt)))
	  (when (zerop (seo-count elt))
	    (do ((tail (cdr tem) (cdr tail)))
		((null tail))
	      (when (and (listp (car tail))
			 (eq (caar tail) 'setq)
			 (eq (cadar tail) (seo-tempvar elt)))
		(setf (car tail) (caddar tail))
		(return)))))))
    ;; Now see which temp vars still remain in use,
    ;; and put on a binding for them.
    (let ((tempvars-used
	    (loop for elt in nonconstant-alist
		  when (not (zerop (seo-count elt)))
		  collect (list (seo-tempvar elt) '(compiler:undefined-value)))))
      (if tempvars-used
	  `(let ,tempvars-used ,value-so-far)
	  value-so-far))))

(defun sublis-eval-once-1 (exp alist &optional reuse-flag sequential-flag)
  (if (null alist) exp
    (if (symbolp exp)
	(let ((tem (assoc exp alist :test #'eq)))
	  (cond ((null tem) exp)
		((seo-tempvar tem)
		 (incf (seo-count tem))
		 (seo-tempvar tem))
		((eq (seo-count tem) t)
		 (seo-exp tem))
		(t
		 (setf (seo-tempvar tem)
		       (if reuse-flag (car tem) (gensym)))
		 (setf (seo-count tem) 0)
		 (setf (seo-first-use tem)
		       (cons 'progn nil))
		 (let ((e1
			 `(,@(loop for tail on seo-first-uninserted-var
				   until (eq (car tail) tem)
				   do (setf (seo-tempvar (car tail))
					    (if reuse-flag (caar tail) (gensym)))
				   (setf (seo-first-use (car tail)) (seo-first-use tem))
				   collect `(setq ,(seo-tempvar (car tail))
						  ,(if sequential-flag
						       (sublis-eval-once-1
							 (seo-exp (car tail))
							 (ldiff alist tail))
						     (seo-exp (car tail))))
				   finally (setq seo-first-uninserted-var (cdr tail)))
			   (setq ,(seo-tempvar tem)
				 ,(if sequential-flag
				      (sublis-eval-once-1 (seo-exp tem)
							  (ldiff alist (member tem alist :test #'eq)))
				    (seo-exp tem))))))
		   (setf (cdr (seo-first-use tem)) e1)
		   (seo-first-use tem)))))
      (if (atom exp) exp
	(do ((tail exp (cdr tail))
	     accum)
	    ((atom tail)
	     (nreconc accum tail))
	  (push (sublis-eval-once-1 (car tail) alist reuse-flag sequential-flag)
		accum))))))


;;Function used to extract a place from its surrounding THE expression

(defun parse-the-in-place (place)
  (if (eq (car-safe place) 'the)
      (parse-the-in-place (cadr-safe (cdr-safe place)))
      place))

;;; 03/15/89 clm - Integrated CLOS version into Kernel.
(defun get-setf-method-multiple-value (form &optional short-cut &aux tem form1)
  "Return the canonical five values that say how to do SETF on FORM.
The values are:
* a list of symbols, gensyms, that stand for parts of FORM
* a list of the parts of FORM that they stand for
* a list of symbols, gensyms, that stand for the values to be stored
* an expression to do the storing.  It contains the gensyms described already.
* an expression to refer to the existing value of FORM.
  It differs from FORM in that it has the gensyms replacing the
  parts of FORM that they stand for.
These values give all the information needed to examine and set
 FORM repeatedly without evaluating any of its subforms more than once.

If SHORT-CUT is non-NIL, and if FORM's method of SETFing was defined
by a simple DEFSETF that just gives a function to do the setting,
then we return just two values: the setting function and a replacement FORM
\(differing from FORM by having macros expanded, CADR -> CAR (CDR ...), etc.).
The caller can tell that this case occurred because the first value
is a non-NIL symbol in this case, and is always a list in the normal case."
  (declare (values tempvars tempargs storevars storeform refform))
  (cond ((symbolp (Setf form (parse-the-in-place form)))
	 (let ((g (gensym)))
	   (values nil nil (list g) `(setq ,form ,g) form)))
	((atom form))
	((not (symbolp (setf form1 (car form))))
	 (ferror nil "~S non-symbolic function in SETF." form1))
	((or (eq (getdecl form1 'setf-method) 'unsetfable)
             (eq (getdecl form1 'setf) 'unsetfable))
	 (nosetf form))
	((setq tem (getdecl form1 'setf-method))
	 (if (symbolp tem)
	     (if short-cut
		 (values tem form)
	       (let ((gs (mapcar #'(lambda (ignore) (gensym)) (cdr form)))
		     (g (gensym)))
		 (values gs (cdr form) (list g)
			 `(,tem ,@gs ,g)
			 `(,form1 ,@gs))))
	   (if (eq (cdr tem) 'nosetf)
	       (nosetf form))
	   (funcall (cdr tem) form si:*macroexpand-environment* )))
	((setq tem (getdecl form1 'setf-expand))
	 (get-setf-method-multiple-value (funcall tem form) short-cut))
	((and (fboundp form1)
	      (arrayp (symbol-function form1)))
	 (get-setf-method-multiple-value `(aref #',form1 . ,(cdr form)) short-cut))
	((and (fboundp form1)
	      (symbolp (symbol-function form1)))
	 (get-setf-method-multiple-value `(,(symbol-function form1) . ,(cdr form)) short-cut))
	((not (eq form (setq form (macroexpand-1 form 
						 si:*macroexpand-environment*))))
	 (get-setf-method-multiple-value form short-cut))
	(t (let ((gs (mapcar #'(lambda (ignore) (gensym)) (cdr form)))
		 (g (gensym)))
	     (values gs (cdr form) (list g)
		     `(funcall (function (setf ,(car form))) ,g ,@gs )
		     `(,form1 ,@gs))))
	))

(defprop nosetf t :error-reporter)
(defun nosetf (form)
  (ferror 'unknown-locf-reference
	  "SETF is explicitly forbidden on ~S." (car form)))

(defun get-setf-method (form)
  "Return the canonical five values that say how to do SETF on FORM.
Like GET-SETF-METHOD-MULTIPLE-VALUE except that it will never return
more than one element in the third value, the STOREVARS."
  (declare (values tempvars tempargs storevars storeform refform))
  (multiple-value-bind (tempvars argforms storevars storeform accessform)
      (get-setf-method-multiple-value form)
    (unless (= (length storevars) 1)
	(ferror nil "Number of store-variables not one, for SETF method of ~S."
		form))
    (values tempvars argforms storevars storeform accessform)))

;;PHD 1/16/87 Added eval-when form around defmacro.
(defmacro define-setf-method (access-function lambda-list  &environment env &body body)
  "General way to define how to SETF forms starting with ACCESS-FUNCTION.
This form defines a macro which will be invoked by GET-SETF-METHOD-MULTIPLE-VALUE.
The LAMBDA-LIST is matched, DEFMACRO-style, against the form to be SETF'd.
Then the BODY is executed and should produce five values to return from
GET-SETF-METHOD-MULTIPLE-VALUE.
See that function for a description of what the five values mean.
This is more general than DEFSETF because it can decide how to parse
the form to be SETF'd, decide which parts to replace with tempvars, and so on.

A trivial example would be
\(DEFINE-SETF-METHOD CAR (LIST)
  (LET ((TEMPVARS (LIST (GENSYM)))
	(TEMPARGS (LIST LIST))
	(STOREVAR (GENSYM)))
    (VALUES TEMPVARS TEMPARGS (LIST STOREVAR)
	    `(SETCAR ,(FIRST TEMPVARS) ,STOREVAR)
	    `(CAR ,(FIRST TEMPVARS)))))
which is equivalent to (DEFSETF CAR SETCAR)."
  (multiple-value-bind (body decls doc-string)
      (parse-body body env t)
        `(progn
       (set-documentation ',access-function 'setf ,doc-string)
       (eval-when (eval compile load)
	 (defmacro (:property ,access-function setf-method) ,lambda-list ,@decls . ,body)))))


(defmacro defsetf (access-function arg1 &optional arg2  &environment env &body body)
  "Define a SETF expander for ACCESS-FUNCTION.
DEFSETF has two forms:

The simple form  (DEFSETF access-function update-function [doc-string])
can be used as follows: After (DEFSETF GETFROB PUTFROB),
\(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO).

The complex form is like DEFMACRO:

\(DEFSETF access-function access-lambda-list newvalue-lambda-list body...)

except there are TWO lambda-lists.
The first one represents the argument forms to the ACCESS-FUNCTION.
Only &OPTIONAL and &REST are allowed here.
The second has only one argument, representing the value to be stored.
The body of the DEFSETF definition must then compute a
replacement for the SETF form, just as for any other macro.
When the body is executed, the args in the lambda-lists will not
really contain the value-expression or parts of the form to be set;
they will contain gensymmed variables which SETF may or may not
eliminate by substitution."
  ;; REF and VAL are arguments to the expansion function
  (if (null body)
      `(defdecl ,access-function setf-method ,arg1)
      (multiple-value-bind (body decls doc-string)
	  (parse-body body env t)
	(let* ((access-ll arg1)
	       (value-names arg2)
	       (expansion
		 (let (all-arg-names)
		   (dolist (x access-ll)
		     (cond ((symbolp x)
			    (if (not (member x lambda-list-keywords :test #'eq))
				(push x all-arg-names)
				(when (eq x '&rest) (return))))  ;;9/20/88 clm
			   (t			; it's a list after &optional
			    (push (car x) all-arg-names))))
		   (setq all-arg-names (reverse all-arg-names))
		   `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names))
			  (storevar (gensym)))
		      (values tempvars (list . ,all-arg-names) (list storevar)
			      (let ((,(car value-names) storevar)
				    . ,(loop for arg in all-arg-names
					     for i = 0 then (1+ i)
					     collect `(,arg (nth ,i tempvars))))
				 ,@decls . ,body)
			      `(,',access-function . ,tempvars))))))
	  `(define-setf-method ,access-function ,arg1
	    ,@doc-string ,expansion)
	  ))))

;;;PHD 6/23/86 New Common Lisp function 
(defun delete-setf-method (access-fn)
  "delete the setf method associated with the accessor function access-fn"
  (dolist (prop '(setf setf-method setf-expand))
    (when (get access-fn prop)
      (remprop access-fn prop))))

;;; 03/15/89 clm - Integrated function into Kernel for CLOS.
(defun delete-locf-method (access-fn)
  "delete the locf method associated with the accessor function access-fn"
  (dolist (prop '(locf locf-method))
    (when (get access-fn prop)
      (remprop access-fn prop))))

;;PHD 9/8/86 fix define-modify-macro.
;;AB for PHD 7/14/87.  Fix so (INCF (AREF a (RANDOM n))) only evaluates (RANDOM n) once.  [SPR 5426]
(defmacro DEFINE-MODIFY-MACRO (name additional-arglist action-function
                               &OPTIONAL doc-string)
  "Define a construct which, like INCF, modifies the value of its first argumenty.
NAME is defined so that (NAME place additional-args) expands into
  (SETF place (action-function place additional-args))
except that subforms of place are evaluated only once."
  (let ((additional-arg-names nil)
        (rest-arg nil))
    ;; Parse out the variable names and rest arg from the lambda list.
    (do ((xl additional-arglist (rest xl))
	 (arg nil))
	((null xl))
      (setq arg (first xl))
      (cond ((eq arg '&OPTIONAL))
	    ((eq arg '&REST)
	     (if (symbolp (second xl))
		 (setq rest-arg (second xl))
		 (error "Non-symbol &REST argument in definition of ~S." name))
	     (if (null (cddr xl))
		 (return nil)
		 (error "Additional arguments following &REST arg in DEFINE-MODIFY-MACRO.")))
	    ((member arg '(&KEY &ALLOW-OTHER-KEYS &AUX) :test #'eq)
	     (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
	    ((symbolp arg)
	     (push arg additional-arg-names))
	    ((and (listp arg) (symbolp (first arg)))    ; Optional arg syntax.
	     (push (first arg) additional-arg-names))))
    (setq additional-arg-names (nreverse additional-arg-names))      
    `(defmacro ,name (place . ,additional-arglist)
       ,doc-string
       (if (symbolp (parse-the-in-place place))
	   ;; Special case for simple SETQs to speed up the expansion process and
           ;; generate better code ::
           `(setq ,(parse-the-in-place place)
		  (,',action-function ,place ,,@additional-arg-names ,@,rest-arg))
           ;; General case ::
	   (multiple-value-bind (tempvars tempargs storevars storeform refform)
	       (get-setf-method place)
	     (sublis-eval-once  (pairlis tempvars tempargs)
				(sublis-eval-once
				  (list (cons (car storevars)
					      (list* ',action-function refform ,@additional-arg-names ,rest-arg)))
				  storeform)
				  t t))))))

;;01/08/88 CLM - added the COMPILER-LET (as in sys patch 3.47) to make new hash values
;;consistent with previous hash values.
(COMPILER-LET ((local-declarations '((:expr-sxhash 1342021.))))	
(define-modify-macro incf (&optional (delta 1)) +
		     "Increment PLACE's value by DELTA.")
)

(COMPILER-LET ((local-declarations '((:expr-sxhash 5321811.))))	
(define-modify-macro decf (&optional (delta 1)) -
		     "Decrement PLACE's value by DELTA.")
)

(define-setf-method getf (place indicator &optional default)
  ;; Process trivial case first
  (if (symbolp (parse-the-in-place place))
      (let ((store (gensym))
	    (ind (gensym))
	    (def (gensym)))
	(Values (list ind def )
		(list indicator default )
		(list store)
		`(setf (get (locf ,place ) ,ind) ,store)
		`(get (locf ,place) ,ind ,def)))
      (multiple-value-bind (temps vals stores store-form access-form)
	  (get-setf-method place)
	(let ((btemp (gensym))
	      (store (gensym))
	      (stemp (first stores)))
	  (values (list* btemp temps)
		  (list* indicator vals)
		  (list store)
		  (if (get (car place) 'locf-method)
		      ;; If there is a locf-method, store-form is not necessary.
		      `(setf (get (locf ,access-form) ,btemp) ,store)
		      `(let* ((,stemp ,access-form))
			 (setf (get (locf ,stemp ) ,btemp ) ,store)
			 ,store-form
			 ,store))
		  `(getf ,access-form ,btemp ,default))))))

(defmacro push (value place)
  "Add ITEM to the front of the list PLACE, using CONS.
Works by SETF'ing PLACE."
  (if (symbolp (parse-the-in-place place))
      ;; Special case this to speed up the expansion process and make better code.
      `(setq ,(parse-the-in-place place) (cons ,value ,place))
    (multiple-value-bind (tempvars tempargs storevars storeform refform)
	(get-setf-method place)
      (let ((val (gensym)))
	(sublis-eval-once (cons `(,val . ,value) (pairlis tempvars tempargs))
			  (sublis-eval-once (list (cons (car storevars)
					      `(cons ,val ,refform)))
				  storeform)
			  t t)))))

(DEFMACRO PUSH-END (item item-list)
  "This is similar to PUSH except that it puts the new element at the end
of the existing list.  This preserves the order of the elements as they are added to
the list."
  `(SETF ,item-list (NCONC ,item-list (cons  ,item nil ))))

(defmacro pop (place &optional into-place)
  "Remove the first element from the list PLACE, and return that element.
Works by SETF'ing PLACE.  If INTO-PLACE is specified, store the
value there as well as returning it."
  (if (and (symbolp (parse-the-in-place place))
	   (symbolp (parse-the-in-place into-place)))
      ;; Special case this to speed up the expansion process and make better code.
      (if into-place
	  `(prog1 (setf ,(parse-the-in-place into-place) (car ,place))
		  (setq ,(parse-the-in-place place) (cdr ,place)))
	`(prog1 (car ,place) (setq ,(parse-the-in-place place) (cdr ,place))))
    (if into-place
	(multiple-value-bind (into-tempvars into-tempargs into-storevars into-storeform)
	    (get-setf-method into-place)
	  (multiple-value-bind (tempvars tempargs storevars storeform refform)
	      (get-setf-method place)
	    (sublis-eval-once (pairlis tempvars tempargs
				       (pairlis into-tempvars into-tempargs))
			      `(prog1 ,(sublis (list (cons (car into-storevars)
							   `(car ,refform)))
					       into-storeform)
				      ,(sublis (list (cons (car storevars)
							   `(cdr ,refform)))
					       storeform))
			      t t)))
      (multiple-value-bind (tempvars tempargs storevars storeform refform)
	  (get-setf-method place)
	(sublis-eval-once (pairlis tempvars tempargs)
			  `(prog1 (car ,refform)
				  ,(sublis (list (cons (car storevars)
						       `(cdr ,refform)))
					   storeform))
			  t t)))))


;;8/15/88 clm - changed to apply any :KEY arg to both new item and each item in the list.
(defmacro pushnew (value place &rest options)
  "Add VALUE to the front of the list PLACE, if it's not already a member of the list."
  (declare (arglist value place &key test test-not key))
  (let ((pl (gensym))
	(val (gensym)))
    (sublis-eval-once `((,val . ,value))
		      (sublis-eval-once `((,pl . ,place))
					(if (and options
						 (or (member :key options :test #'eq) 
						     (do ((x options (cddr x)))
						         ((null x))
						       ;;if not a constant could eval to :key
						       (unless (constantp (car x))  ;;or (keywordp...)
						          (return t)))))
					    `(values (setf ,place (adjoin ,val ,pl ,@options)))
					    `(if (member ,val ,pl ,@options)
						 ,pl
						 (values (setf ,place (cons ,val ,pl)))))))) )


;;01/08/88 CLM - added the COMPILER-LET (as in sys patch 3.47) to make hash code consistent
;;with previous value.
(COMPILER-LET ((local-declarations '((:expr-sxhash 5997798.))))	
;;AB 7/14/87.  Fix SETF with odd number of arguments to error (like SETQ).  [SPR 4285]
(defmacro setf (&rest places-and-values)
  "Sets the value of PLACE to be VALUE.  Allows any number of places and values, like SETQ.
For example, (SETF (AREF A I) NEWVALUE) sets the value of (AREF A I)."
  (let ((code (loop for (place . value) on places-and-values by 'cddr
		    collect
		    (PROGN
		      (IF value
			  (SETQ value (CAR value))
			  (ERROR "no value supplied for ~s in SETF" place))
		      ;; handle the case of (setf symbol value) very simply
		      (typecase place
			(symbol
			 `(setq ,place ,value))
			(number
			 (error " ~S is not a valid place for SETF" place))
			(t 
			 (multiple-value-bind (tempvars tempargs storevars storeform)
			     (get-setf-method-multiple-value place t)
			   (if (and tempvars (symbolp tempvars))
			       ;; Handle case of simple DEFSETF as fast as possible.
			       `(,tempvars ,@(cdr tempargs) ,value)
			       (sublis-eval-once (pairlis tempvars tempargs
							  (list (cons (car storevars) value)))
						 storeform t t))))))
		    )))
    (if (cddr  places-and-values)
	`(progn . ,code)
	(car code))))
)

(define-setf-method ldb (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (itemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(progn 
		 ,(sublis (list (cons itemp `(dpb ,store ,btemp ,access-form)))
			  store-form)
		 ,store)
	      `(ldb ,btemp ,access-form)))))

(define-setf-method %logldb (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (itemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(progn 
		 ,(sublis (list (cons itemp `(%logdpb ,store ,btemp ,access-form)))
			  store-form)
		 ,store)
	      `(%logldb ,btemp ,access-form)))))

(define-setf-method ldb-test (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (itemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(progn 
		 ,(sublis (list (cons itemp `(dpb (if ,store 1 0) ,btemp ,access-form)))
			  store-form)
		 ,store)
	      `(ldb-test ,btemp ,access-form)))))

(define-setf-method %logldb-test (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (itemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(progn 
		 ,(sublis (list (cons itemp `(%logdpb (if ,store 1 0) ,btemp ,access-form)))
			  store-form)
		 ,store)
	      `(%logldb-test ,btemp ,access-form)))))

(define-setf-method mask-field (bytespec int)
  (multiple-value-bind (temps vals stores store-form access-form)
      (get-setf-method int)
    (let ((btemp (gensym))
	  (store (gensym))
	  (itemp (first stores)))
      (values (cons btemp temps)
	      (cons bytespec vals)
	      (list store)
	      `(progn 
		 ,(sublis (list (cons itemp `(deposit-field ,store ,btemp ,access-form)))
			  store-form)
		 ,store)
	      `(mask-field ,btemp ,access-form)))))

(defmacro rotatef (&rest places)
  "Rotates the values between all the specified PLACEs.
The second PLACE's value is put into the first PLACE,
the third PLACE's value into the second PLACE, and so on,
and the first PLACE's value is put into the last PLACE."
  (let ((setf-methods
	  (mapcar #'(lambda (place)
		      (multiple-value-list (get-setf-method place)))
		  places)))
    `(let* (,@(mapcan #'(lambda (setf-method)
			 (mapcar #'list (first setf-method)
				  (second setf-method)))
		     setf-methods)
	    ,@(nreverse(maplist #'(lambda (setf-method-sublist)
			  `(,(first (third (car setf-method-sublist)))
			    ,(if (cdr setf-method-sublist)
				 (fifth (second setf-method-sublist))
				 (fifth (first setf-methods)))))
		      setf-methods)))
       ,@(mapcar #'(lambda (setf-method) (fourth setf-method))
		 setf-methods)
       nil)))


(deff swapf #'rotatef)

(defmacro shiftf (&rest places-and-final-value)
  "Copies values into each PLACE from the following one.
The last PLACE need not be SETF'able, as it is only accessed
 to get a value to put in the previous PLACE; it is not set.
The first PLACE's original value is returned as the value of the SHIFTF form."
  (let* ((places (butlast places-and-final-value))
	 (value (car (last places-and-final-value)))
	 (setf-methods
	   (mapcar #'(lambda (place)
		       (multiple-value-list (get-setf-method place)))
		   places)))
    `(let* (,@(mapcan #'(lambda (setf-method)
			 (mapcar #'list (first setf-method)
				  (second setf-method)))
		     setf-methods)
	    ,@(nreverse (maplist #'(lambda (setf-methods)
			  `(,(first (third (car setf-methods)))
			    ,(if (cdr setf-methods)
				 (fifth (second setf-methods))
				 value)))
		      setf-methods)))
       (prog1 ,(fifth (car setf-methods))
       ,@(mapcar #'(lambda (setf-method) (fourth setf-method))
		 setf-methods)))))
       

(defmacro psetf (&rest rest)
  "Like SETF, but no variable value is changed until all the values are computed.
The returned value is undefined."
  (if (do ((pairs rest (cddr pairs)))
	  ((endp pairs) nil)
	(unless (symbolp (car pairs ))
	  (return t)))
      `(progn ,(psetf-prog1ify rest) nil)
      `(psetq ,@rest)))

(defun psetf-prog1ify (x)
  (cond ((null x) nil)
	((null (cddr x)) (cons 'setf x))
	(t `(setf ,(car x) (prog1 ,(cadr x) ,(psetf-prog1ify (cddr x)))))))

(define-setf-method apply (function &rest args)
  (unless (and (consp function)
	       (member (car function) '(function quote) :test #'eq)
	       (eq (length function) 2)
	       (symbolp (cadr function)))
    (ferror 'sys:unknown-setf-reference
	    "In SETF of APPLY, the function APPLYed must be a constant."))
  (multiple-value-bind (tempvars tempargs storevars storeform refform)
      (get-setf-method (cons (cadr function) args))
    (if (or (eq (cadr function) 'aref)  (eq (cadr function) 'global:aref))
	(setq storeform
	      `(ZLC:aset ,(car (last storeform)) . ,(butlast (cdr storeform)))))
    (if (not (eq (car (last storeform)) (car (last tempvars))))
	(ferror 'sys:unknown-setf-reference
		"~S not acceptable within APPLY within SETF." function)
      (values tempvars tempargs storevars
	      `(apply #',(car storeform) . ,(cdr storeform))
	      `(apply #',(car refform) . ,(cdr refform))))))


;; 9/12/88 clm - set the sxhash property to avoid load warnings; only the
;; documentation string has changed in LOCF.
;; 3/15/89 clm - Integrated CLOS version into Kernel.
(COMPILER-LET ((local-declarations '((:expr-sxhash 3795008.))))	; suppress version warnings
(defmacro locf (accessor)
  "Return a locative pointer to the place where ACCESSOR's value is stored.
Note that (CDR (LOCF SOMETHING)) is normally equivalent to SOMETHING,
which may be a list rather than a locative."
  (do-forever
    (let (fcn)
      (cond ((symbolp (setf accessor (parse-the-in-place accessor)))			;SPECIAL CASE NEEDED.
	     (return `(variable-location ,accessor)))
	    ((not (symbolp (car accessor)))
	     (ferror nil "~S non-symbolic function in LOCF" (car accessor)))
	    ((eq (getdecl (car accessor) 'locf) 'unlocfable)
	     (ferror 'unknown-locf-reference
		     "LOCF is explicitly forbidden on ~S." (car accessor)))
	    ((setq fcn (getdecl (car accessor) 'locf-method))
	     (if (symbolp fcn)
		 (return (cons fcn (cdr accessor)))
	       (return (funcall (cdr fcn)  accessor  *macroexpand-environment*))))
	    ((setq fcn (getdecl (car accessor) 'setf-expand))
	     (setq accessor (funcall fcn accessor)))
	    ((and (fboundp (car accessor)) (arrayp (symbol-function (car accessor))))
	     (return `(aloc #',(car accessor) . ,(cdr accessor))))
	    ((and (fboundp (car accessor)) (symbolp (symbol-function (car accessor))))
	     (return `(locf (,(symbol-function (car accessor)) . ,(cdr accessor)))))
	    ((not (eq accessor (setq accessor (macroexpand-1 accessor
							     *macroexpand-environment*)))))
	    (t (return `(funcall (function (locf ,(car accessor))) . ,(cdr accessor))))))))
)

;(GET-LIST-POINTER-INTO-STRUCT (element pntr))
(MACRO get-list-pointer-into-struct (x)
  (prog (ref)
    (setq ref (macroexpand (cadr x)	;EXPAND MACROS LOOKING AT BAG-BITING MACRO LIST
			   *macroexpand-environment*))
    (cond ((eq (car ref) 'ar-1)
	   (return (list 'get-list-pointer-into-array
			 (list 'funcall (cadr ref) (caddr ref)))))
	  ((error "LOSES - GET-LIST-POINTER-INTO-STRUCT" x)))))

;; Primitive DEFSETFs for simple functions.

(defsetf aref set-aref)
(defsetf global:aref set-aref)
(defsetf ar-1 set-ar-1)
(defsetf global:ar-1 set-ar-1)
(defsetf ar-1-force set-ar-1-force)
(defsetf global:ar-1-force set-ar-1-force)
(defsetf ar-2 set-ar-2)
(defsetf ar-3 set-ar-3)
(defsetf array-leader set-array-leader)
(defsetf %instance-ref set-%instance-ref)
(defsetf char set-aref)				;could be set-ar-1
(defsetf schar set-aref)			;could be set-ar-1
(defsetf bit set-aref)				;could be set-ar-1
(defsetf sbit set-aref)				;could be set-ar-1
(defsetf svref set-aref)			;could be set-ar-1
(defsetf elt setelt)
;(defsetf global:elt setelt)

;;PHD 1/13/87 Removed (defsetf char-bit set-char-bit)

(defprop aref aloc locf-method)
(defprop global:aref aloc locf-method)
(defprop ar-1 ap-1 locf-method)
(defprop common-lisp-ar-1 ap-1 locf-method)
(defprop global:ar-1 ap-1 locf-method)
(defprop ar-1-force ap-1-force locf-method)
(defprop global:ar-1-force ap-1-force locf-method)
(defprop ar-2 ap-2 locf-method)
(defprop ar-3 ap-3 locf-method)
(defprop array-leader ap-leader locf-method)
(defprop %instance-ref %instance-loc locf-method)
(defprop char aloc locf-method)			;could be ap-1
(defprop schar aloc locf-method)		;could be ap-1
(defprop bit aloc locf-method)			;could be ap-1
(defprop sbit aloc locf-method)			;could be ap-1
(defprop svref aloc locf-method)		;could be ap-1

(defsetf ar-2-reverse (array i j) (value)
	 `(as-2-reverse ,value ,array ,i ,j))

(defun (:property arraycall setf-expand) (form)
  `(aref . ,(cddr form)))

(defsetf car setcar)
(defsetf cdr setcdr)
(defprop car car-location locf-method)
(defprop cdr identity locf-method)

(defun (:property caar setf-expand) (form)
  `(car (car ,(cadr form))))
(defun (:property cadr setf-expand) (form)
  `(car (cdr ,(cadr form))))
(defun (:property cdar setf-expand) (form)
  `(cdr (car ,(cadr form))))
(defun (:property cddr setf-expand) (form)
  `(cdr (cdr ,(cadr form))))
(defun (:property caaar setf-expand) (form)
  `(car (caar ,(cadr form))))
(defun (:property caadr setf-expand) (form)
  `(car (cadr ,(cadr form))))
(defun (:property cadar setf-expand) (form)
  `(car (cdar ,(cadr form))))
(defun (:property caddr setf-expand) (form)
  `(car (cddr ,(cadr form))))
(defun (:property cdaar setf-expand) (form)
  `(cdr (caar ,(cadr form))))
(defun (:property cdadr setf-expand) (form)
  `(cdr (cadr ,(cadr form))))
(defun (:property cddar setf-expand) (form)
  `(cdr (cdar ,(cadr form))))
(defun (:property cdddr setf-expand) (form)
  `(cdr (cddr ,(cadr form))))
(defun (:property caaaar setf-expand) (form)
  `(car (caaar ,(cadr form))))
(defun (:property caaadr setf-expand) (form)
  `(car (caadr ,(cadr form))))
(defun (:property caadar setf-expand) (form)
  `(car (cadar ,(cadr form))))
(defun (:property caaddr setf-expand) (form)
  `(car (caddr ,(cadr form))))
(defun (:property cadaar setf-expand) (form)
  `(car (cdaar ,(cadr form))))
(defun (:property cadadr setf-expand) (form)
  `(car (cdadr ,(cadr form))))
(defun (:property caddar setf-expand) (form)
  `(car (cddar ,(cadr form))))
(defun (:property cadddr setf-expand) (form)
  `(car (cdddr ,(cadr form))))
(defun (:property cdaaar setf-expand) (form)
  `(cdr (caaar ,(cadr form))))
(defun (:property cdaadr setf-expand) (form)
  `(cdr (caadr ,(cadr form))))
(defun (:property cdadar setf-expand) (form)
  `(cdr (cadar ,(cadr form))))
(defun (:property cdaddr setf-expand) (form)
  `(cdr (caddr ,(cadr form))))
(defun (:property cddaar setf-expand) (form)
  `(cdr (cdaar ,(cadr form))))
(defun (:property cddadr setf-expand) (form)
  `(cdr (cdadr ,(cadr form))))
(defun (:property cdddar setf-expand) (form)
  `(cdr (cddar ,(cadr form))))
(defun (:property cddddr setf-expand) (form)
  `(cdr (cdddr ,(cadr form))))

(defun (:property nth setf-expand) (form)
  `(car (nthcdr . ,(cdr form))))

(defun (:property nthcdr setf-expand) (form)
  `(cdr (nthcdr (1- ,(cadr form)) ,(caddr form))))

(defsetf subseq (sequence start &optional end) (value)
  `(replace ,sequence ,value :START1 ,start :END1 ,end))

(defsetf zlc:symeval set)
(defsetf zlc:fsymeval fset)
(defsetf symbol-value set)
(defsetf symbol-function fset)
(defsetf symeval-in-closure set-in-closure)
(defsetf symbol-package (symbol) (pkg)
	 `(setcar (package-cell-location ,symbol) ,pkg))
(defsetf ZLC:plist ZLC:setplist)
(defsetf symbol-plist ZLC:setplist)

(defsetf get (object property &optional (default nil defaultp)) (value)
  (let ((tem (if defaultp `(prog1 ,property ,default) property)))
    `(setprop ,object ,tem ,value)))

(defsetf gethash (object hash-table &optional (default nil defaultp)) (value)
  (let ((tem (if defaultp `(prog1 ,hash-table ,default) hash-table)))
    `(sethash ,object ,tem ,value)))

(defprop zlc:symeval value-cell-location locf-method)
(defprop zlc:fsymeval function-cell-location locf-method)
(defprop symbol-value value-cell-location locf-method)
(defprop symbol-function function-cell-location locf-method)
(defprop symeval-in-closure locate-in-closure locf-method)
(defprop symbol-package package-cell-location locf-method)
(defprop plist property-cell-location locf-method)
(defprop symbol-plist property-cell-location locf-method)
;(defprop get get-location locf-method)

(defsetf arg setarg)
(defsetf %nubus-read %nubus-write)

(defsetf %p-contents-offset (baseaddr offset) (value)
  `(%p-store-contents-offset ,value ,baseaddr ,offset))

(defsetf %p-ldb (ppss baseaddr) (value)
  `(%p-dpb ,value ,ppss ,baseaddr))

(defsetf %p-ldb-offset (ppss baseaddr offset) (value)
  `(%p-dpb-offset ,value ,ppss ,baseaddr ,offset))

(defsetf %p-mask-field (ppss baseaddr) (value)
  `(%p-deposit-field ,value ,ppss ,baseaddr))

(defsetf %p-mask-field-offset (ppss baseaddr offset) (value)
  `(%p-deposit-field-offset ,value ,ppss ,baseaddr ,offset))

(defsetf %p-data-type %p-store-data-type)
(defsetf %p-cdr-code %p-store-cdr-code)
(defsetf %p-pointer %p-store-pointer)

(defsetf fdefinition (function-spec) (definition)
	 `(fdefine ,function-spec ,definition nil t))
(defprop fdefinition fdefinition-location locf-method)

(defsetf function-spec-get (function-spec property) (value)
	 `(function-spec-putprop ,function-spec ,value ,property))

(defsetf documentation set-documentation)
(defsetf macro-function set-macro-function)

;; New - TGC
(DEFSETF %p-data-type-offset (addr offset) (value)
  `(%p-store-data-type-offset ,value ,addr ,offset))
(DEFSETF %p-cdr-code-offset (addr offset) (value)
  `(%p-store-cdr-code-offset ,value ,addr ,offset))
(DEFSETF %p-pointer-offset (addr offset) (value)
  `(%p-store-pointer-offset ,value ,addr ,offset))
;; TGC

(define-setf-method values (&rest places)
  (if (every #'symbolp places )
      (let ((g (gensym)))
	(values nil nil (list g)
		`(multiple-value-setq ,places ,g)
		g))
      (let ((g (gensym))
	    (ltemp (mapcar #'(lambda (ignore ) (gensym)) places)))
	(values nil nil (list g)
		`(multiple-value-bind ,ltemp ,g
		   ,@(mapcar #'(lambda (x y) `(setf ,x ,y)) places ltemp))
		g))))

;;AB 7-14-87.  Fix (SETF (FUNCTION foo) value) to return value. [SPR 4651]
(define-setf-method function (function-spec)
  (if (validate-function-spec function-spec)
      (let ((g (gensym)))
	(values nil nil (list g)
		`(PROGN (fdefine ',function-spec ,g) ,g)
		`(function ,function-spec)))
    (ferror 'sys:unknown-setf-reference
	    "Cannot SETF a form (FUNCTION x) unless x is a function spec.")))

;;AB 7-14-87.  Fix error message.
(defmacro (:property function locf-method) (function-spec)
  (if (validate-function-spec function-spec)
      `(fdefinition-location ',function-spec)
    (ferror 'sys:unknown-locf-reference
	    "Cannot LOCF a form (FUNCTION x) unless x is a function spec.")))

;;;PHD 7/7/86 Fixed bug that caused binding being used before being defined
;;;during macroexpansion of (setf (subst-fn ...) val) when subst-fn generates bindings.

(define-setf-method progn  (&rest forms &aux (store(gensym)))
  (values () () (list store)
	  `(progn ,@(butlast forms) (setf ,@(last forms) ,store))
	  `(progn ,@forms)))

;;;PHD 7/7/86 Fixed bug that caused binding being used before being defined
;;;during macroexpansion of (setf (subst-fn ...) val) when subst-fn generates bindings.

(define-setf-method let (boundvars &rest forms &aux (store(gensym)))
  (values () () (list store)
	  `(let ,boundvars ,@(butlast forms) (setf ,@(last forms) ,store))
	  `(let ,boundvars ,@forms)))

(defmacro (:property progn locf-method) (&rest forms)
  (let ((new-body (copy-list forms)))
    (setcar (last new-body)
	    `(locf ,(car (last new-body))))
    `(progn . ,new-body)))

(defmacro (:property let locf-method) (boundvars &rest forms)
  (let ((new-body (copy-list forms)))
    (setcar (last new-body)
	    `(locf ,(car (last new-body))))
    `(let ,boundvars . ,new-body)))

;;;PHD 8/28/86 added setf method and locf method for THE.
;;;I defined a setf-expand instead of a setf-method because it is more efficient,
;;;the setf-method would have required a gensym that would be thrown away later on.
;;;Here is the equivalent defsetf:
;;(define-setf-method the (type form &aux (store (gensym)))
;;  (values () () (list store)
;;	  `(setf ,form ,store)
;;	  `(the ,type ,form)))

(defun (:property the setf-expand) (form)
  (third form))

(defmacro (:property the locf-method) (type form)
  (declare (ignore type))
  `(locf ,form))  

(define-setf-method funcall (function arg1 &rest args)
  (and (or (atom arg1) (neq (car arg1) 'quote))
       (ferror 'unknown-setf-reference "Can only SETF message-sending FUNCALLs."))
  (let ((tempvars (list* (gensym) (mapcar #'(lambda (ignore) (gensym)) args)))
	(storevar (gensym))
	(operation (cadr arg1)))
    (values tempvars (cons function args) (list storevar)
	    (if (eq operation ':get)
		`(funcall ,(car tempvars) ':putprop
			  ,storevar . ,(cdr tempvars))
	      `(funcall ,(car tempvars)
			',(intern (string-append "SET-" operation) "")
			,storevar))
	    `(funcall ,(car tempvars) ,arg1 . ,(cdr tempvars)))))

(define-setf-method send (function arg1 &rest args)
  ;; phd 10/10/85: when the operation is a keyword or a quoted keyword,
  ;; then use :set-symbol instead of :set :symbol.
  ;; phd 12/4/85 check there are no extra arguments.
  (let ((tempvars (list* (gensym) (mapcar #'(lambda (ignore) (gensym)) args)))
	(storevar (gensym)))
    (values tempvars (cons function args) (list storevar)
	    (if (and (null args)
		     (or (keywordp arg1)
			 (and (consp arg1) (eq (car arg1) 'quote)
			      (consp (cdr arg1)) (keywordp (second arg1))
			      (null (cddr arg1)))))
		`(send ,(car tempvars) ,(intern (string-append "SET-"
							       (if (consp arg1 ) (second arg1) arg1))
						'keyword)
		       ,@(cdr tempvars),storevar)
		`(send ,(car tempvars) ':set ,arg1 ,@(cdr tempvars)
		       ,storevar))
	    `(send ,(car tempvars) ,arg1 . ,(cdr tempvars)))))

(setf (get 'funcall 'setf-method) (get 'send 'setf-method))

(setf (documentation 'funcall 'setf) (documentation 'send 'setf))

(define-setf-method lexpr-send (function arg1 &rest args &aux operation)
  (cond ((keywordp arg1) (setq operation arg1))	;(send foo :bar)
	((and (consp arg1)			;(send foo ':bar)
	      (eq (car arg1) 'quote)
	      (symbolp (cadr arg1))
	      (eq (length arg1) 2))
	 (setq operation (cadr arg1)))
	(t (ferror 'unknown-setf-reference "Can only SETF message-sending SENDs.")))
  (let ((tempvars (list* (gensym) (mapcar #'(lambda (ignore) (gensym)) args)))
	(storevar (gensym)))
    (values tempvars (cons function args) (list storevar)
	    (if (eq operation ':get)
		`(lexpr-send ,(car tempvars) ':putprop
			     ,storevar . ,(cdr tempvars))
	      `(lexpr-send ,(car tempvars)
			   ;; replace this with a send of :SET operation in new vanilla flavor
			   ',(intern (string-append "SET-" operation) pkg-keyword-package)
			   ,storevar))
	    `(lexpr-send ,(car tempvars) ,arg1 . ,(cdr tempvars)))))

;Wasn't really needed - but is it a good idea?
;(define-setf-method not (boolean)
;  (multiple-value-bind (tempvars tempargs storevars storeform refform)
;      (get-setf-method boolean)
;    (values tempvars tempargs storevars
;	    (sublis (list (cons (car storevars)
;				`(not ,(car storevars))))
;		    storeform)
;	    `(not ,refform))))

;; Handle (SETF (DONT-OPTIMIZE (defsubst-function args)) ...)
;; Return a call to a function that will be created at load time.

(define-setf-method dont-optimize (ref)
  (let* ((fun (car ref))
	 (def (fdefinition-safe fun t)))
    (unless (member (car (COMPILER:INTERPRETED-DEF def))
		  '(subst named-subst global:subst global:named-subst) :test #'eq)
      (ferror 'unknown-setf-reference "~S is not a subst function." fun))
    (let ((tempvars (mapcar #'(lambda (ignore) (gensym)) (cdr ref)))
	  (storevar (gensym)))
      (values tempvars (cdr ref) (list storevar)
	      `(funcall (quote-eval-at-load-time (setf-function ',fun ,(1- (length ref))))
			,@tempvars ,storevar)))))

;; Return the function to do the work of setf'ing FUNCTION applied to NARGS args.
;; If no such function has been created yet, one is created now.
;; We must have different functions for different numbers of args
;; so that problems with how args get defaulted are avoided.
(defun setf-function (function nargs)
  (or (nth nargs (get function 'run-time-setf-functions))
      (let* ((vars (setf-function-n-vars nargs))
	     (name (make-symbol (format nil "SETF-~A-~D-ARGS" function nargs) t)))
	(compiler:compile-now-or-later name
		 `(lambda (,@vars val)
		    (setf (,function . ,vars) val)))
	(unless (> (length (get function 'run-time-setf-functions)) nargs)
	  (setprop function 'run-time-setf-functions
		   (append (get function 'run-time-setf-functions)
			   (make-list (- (1+ nargs)
					 (length (get function 'run-time-setf-functions)))))))
	(setcar (nthcdr nargs (get function 'run-time-setf-functions))
		name)
	name)))

(defmacro (dont-optimize locf-method) (form)
  (let* ((fun (car form))
	 (def (fdefinition-safe fun t)))
    (unless (member (car (COMPILER:INTERPRETED-DEF def))
		  '(subst named-subst global:subst global:named-subst) :test #'eq)
      (ferror 'unknown-locf-reference "~S is not a subst function." fun))
    `(funcall (quote-eval-at-load-time (locf-function ',fun ,(1- (length form))))
	      ,@(cdr form))))

(defun locf-function (function nargs)
  (or (nth nargs (get function 'run-time-locf-functions))
      (let* ((vars (setf-function-n-vars nargs))
	     (name (make-symbol (format nil "LOCF-~A-~D-ARGS" function nargs) t)))
	(compiler:compile-now-or-later name
		 `(lambda ,vars
		    (locf (,function . ,vars))))
	(unless (> (length (get function 'run-time-locf-functions)) nargs)
	  (setprop function 'run-time-locf-functions
		   (append (get function 'run-time-locf-functions)
			   (make-list (- (1+ nargs)
					 (length (get function 'run-time-locf-functions)))))))
	(setcar (nthcdr nargs (get function 'run-time-locf-functions))
		name)
	name)))

(defvar setf-function-n-vars nil)

(defun setf-function-n-vars (n)
  "Return a list of N distinct symbols.
The symbols are reused each time this function is called."
  (do () ((>= (length setf-function-n-vars) n))
    (push (gensym) setf-function-n-vars))
  (firstn n setf-function-n-vars))

;; Not yet converted.

;Handle SETF of backquote expressions, for decomposition.
;For example, (SETF `(A ,B (D ,XYZ)) FOO)
;sets B to the CADR and XYZ to the CADADDR of FOO.
;The constants in the pattern are ignored.

;Backquotes which use ,@ or ,. other than at the end of a list
;expand into APPENDs or NCONCs and cannot be SETF'd.

(COMMENT
;This was used for making (setf `(a ,b) foo) return t if
;foo matched the pattern (had A as its car).
;The other change for reinstalling this
;would be to replace the PROGNs with ANDs
;in the expansions produced by (LIST SETF), etc.
(DEFUN SETF-MATCH (PATTERN OBJECT)
  (COND ((NULL PATTERN) T)
	((SYMBOLP PATTERN)
	 `(PROGN (SETQ ,PATTERN ,OBJECT) T))
	((EQ (CAR PATTERN) 'QUOTE)
	 `(EQUAL ,PATTERN ,OBJECT))
	((MEMQ (CAR PATTERN)
	       '(CONS LIST LIST*))
	 `(SETF ,PATTERN ,OBJECT))
	(T `(PROGN (SETF ,PATTERN ,OBJECT) T)))))

;This is used for ignoring any constants in the
;decomposition pattern, so that (setf `(a ,b) foo)
;always sets b and ignores a.
(defun setf-match (pattern object)
  (cond ((and (not (atom pattern)) (eq (car pattern) 'quote))
	 nil)
	(t `(setf ,pattern ,object))))

(define-setf-method list (&rest elts)
  (let ((storevar (gensym)))
    (values nil nil (list storevar)
	    (do ((i 0 (1+ i))
		 (accum)
		 (args elts (cdr args)))
		((null args)
		 (cons 'progn (nreverse accum)))
	      (push (setf-match (car args) `(nth ,i ,storevar)) accum))
	    `(incorrect-structure-setf list . ,elts))))

(define-setf-method list* (&rest elts)
  (let ((storevar (gensym)))
    (values nil nil (list storevar)
	    (do ((i 0 (1+ i))
		 (accum)
		 (args elts (cdr args)))
		((null args)
		 (cons 'progn (nreverse accum)))
	      (cond ((cdr args)
		     (push (setf-match (car args) `(nth ,i ,storevar)) accum))
		    (t (push (setf-match (car args) `(nthcdr ,i ,storevar)) accum))))
	    `(incorrect-structure-setf list* . ,elts))))

(define-setf-method cons (car cdr)
  (let ((storevar (gensym)))
    (values nil nil (list storevar)
	    `(progn ,(setf-match car `(car ,storevar))
		    ,(setf-match cdr `(cdr ,storevar)))
	    `(incorrect-structure-setf cons ,car ,cdr))))

(defmacro incorrect-structure-setf (&rest args)
  (ferror nil "You cannot SETF the place ~S~% in a way that refers to its old contents."
	  args))


;;PHD 5/2/85 Change the macroexpansion so it does not produces the third argument
;;if it would have been NIL. This allows for downward compatibility with old version of get-location.
(defmacro (get locf-method)  (place prop &optional default)
  `(get-location ,place
		 ,prop
		 ,@(and default `((locf ,default)))))



;;;03/16/89 clm - Integrated into the Kernel for CLOS.
;;  3/21/89 DNG - Don't wrap DEF form around the DEFUN because Genasys can't handle that.
(def report-undefined-function) ; defined by the following two forms.
(defun set-undefined-function-trap (property)
    ;; This is used to trap attempts to call an undefined SETF or LOCF function.
    ;; The argument is the list which is the initial value of the SETF-FUNCTION 
    ;; or LOCF-FUNCTION property, with the function spec as the first element 
    ;; (used by the disassembler) and the function definition cell as the 
    ;; second element.  A function is stored into the second element that will 
    ;; signal an error if it is called.
    ;; 11/02/88 DNG - Original version.
    (let ((fn #'(lambda (&rest ignore)
		  (let ((location (locf (second property))))
		    (ferror (make-condition 'undefined-function
					    :address location
					    :current-address location
					    :cell-type ':function
					    :symbol (first property)
					    :containing-structure property
					    :data-type (%p-data-type location)
					    :pointer (%p-pointer location)
					    ))))))
      (setf (second property) fn)
      fn))
;; Rename the trap function to have a symbol as its name so that the 
;; :ERROR-REPORTER property can be attached to it -- this causes the 
;; debugger to display the frame that called the undefined function.
(let ((dbi (get-debug-info-struct (set-undefined-function-trap (list nil nil))))
      (sys:%inhibit-read-only t))
  (setf (dbi-name dbi) 'report-undefined-function))
(defprop report-undefined-function t :error-reporter)
(defun undefined-function-p (value)
  (or (null value)
      (and (typep value 'lexical-closure)
	   (eq (function-name value) 'report-undefined-function))))

;;;Support for setf functions

;; 11/02/88 DNG - Add use of SET-UNDEFINED-FUNCTION-TRAP and fix bug in FUNDEFINE.
;; 11/16/88 DNG - Not valid when list is longer than 2.
;;  1/21/89 DNG - Return second value from FDEFINEDP.
;;  1/30/89 DNG - Let FUNCTION-PARENT operation be handled by the default handler 
;;                instead of signalling an error.
;;  4/04/89 DNG - Use new function INVALID-FUNCTION-SPEC .
;;  4/24/89 DNG - Merge SETF and LOCF handlers using new function 
;;		SETF-SPEC-HANDLER .  Put the function spec properties in the list on the 
;;		symbol's plist instead of the function spec hash table.

(defun (:property setf sys:function-spec-handler) (&rest args)
  (apply #'setf-spec-handler 'setf-function #'sys:delete-setf-method args))

(defun (:property locf sys:function-spec-handler) (&rest args)
  (apply #'setf-spec-handler 'locf-function #'sys:delete-locf-method args))

(defun setf-spec-handler (key deletef function function-spec &optional arg1 arg2)
  (let* ((second (cadr-safe function-spec))
	 (gfunc-name (cond ((symbolp second) second)
			   ((functionp second) (function-name second))
			   (t nil))))
    (if (or (null gfunc-name)
	    (not (symbolp gfunc-name)))
	(unless (member function '(sys:validate-function-spec ) :test #'eq)
	  (invalid-function-spec function-spec))
      (labels ((get-spec-list (symbol &optional (if-doesnt-exist :error))
	           (or (getdecl symbol key)
		       (case if-doesnt-exist
			 (:create
			  (let ((list (list function-spec nil)))
			    (set-undefined-function-trap list)
			    (setf (get-spec-list gfunc-name) list)
			    list))
			 (nil nil)
			 (t (error "~s does not have a ~A function defined."
				   symbol (car function-spec))))))
	       ((setf get-spec-list) (value symbol)
		(if compiler:UNDO-DECLARATIONS-FLAG
		    (putdecl symbol key value)
		  (setf (get symbol key) value))))
	(case function
	  (sys:validate-function-spec (null (cddr function-spec)))
	  (sys:fdefinition (cadr (get-spec-list gfunc-name )))
	  ((sys:fdefinedp sys:compiler-fdefinedp)
	   (let ((l (get-spec-list gfunc-name nil)))
	     (and l (not (undefined-function-p (cadr l)))
		  (values t (cadr l)))))
	  (sys:fdefine (funcall deletef gfunc-name)	;Clean up old defsetf definition.
		       (let ((l (get-spec-list gfunc-name nil)))
			 (if l
			     (setf (cadr l) arg1)
			   (setf (get-spec-list gfunc-name )
				 (list function-spec arg1)))))
	  (sys:fdefinition-location
	   (let ((p (get-spec-list gfunc-name :create)))
	     (locf (cadr p))))
	  (sys:fundefine
	   (let ((l (get-spec-list gfunc-name nil)))
	     (unless (null l)
	       (set-undefined-function-trap l)))
	   gfunc-name)
	  
	  (get (getf (cddr (get-spec-list gfunc-name nil)) arg1 arg2))
	  (putprop
	   (let* ((default-cons-area sys:background-cons-area)
		  (list (get-spec-list gfunc-name :create)))
	     (setf (getf (cddr list) arg2) arg1)))
	  (sys:push-property
	   (let* ((default-cons-area sys:background-cons-area)
		  (list (get-spec-list gfunc-name :create)))
	     (push arg1 (getf (cddr list) arg2))))
	  
	  (otherwise (sys:function-spec-default-handler function function-spec arg1 arg2)))))))


;;  4/24/89 DNG - Moved TICLOS:DEFINE-WITHOUT-REDEFINITION-QUERY to file "CLOS;FIRSTDEFS".