The dogma killed ASET

[David A. Moon <Moon%SCRC-TENEX%MIT-MC@SU-DSN>]

    Date: Thursday, 2 June 1983, 16:35-EDT
    From: Bernard S. Greenberg <BSG%SCRC-TENEX@MIT-MC>
    While writing some common lisp code today, I was reminded that ASET
    was removed because "You should be using SETF".  Unfortunately,
    what I wanted to do was (apply #'aset value array list-of-subscripts),
    a very reasonable thing in a recursive array-processing program,
    and I find there is no way to do this in Common Lisp.  Opinions?

The following works and is in our implementation now.  It isn't as complicated
as it looks at first, since almost all of it is error-checking.  I admit that
it's rather a kludge, and maybe we should say that knowledge of APPLY has to
be built into SETF (actually into GET-SETF-METHOD).  But one way or the other
it seems eminently reasonable for
	(SETF (APPLY #'AREF ARRAY SUBSCRIPTS) VALUE)
to be defined to work.

Opinions?

Code:
;Pretend the last argument is only a single argument, get the setf method
;for that form, then stick APPLY back in.  Since this doesn't understand
;the code it is generating in any deep way, it can be fooled into generating
;wrong code when it should have generated an error at macroexpansion time
;saying that it doesn't understand what it's doing.
(DEFINE-SETF-METHOD APPLY (FUNCTION &REST ARGS)
  (IF (AND (LISTP FUNCTION)
	   (= (LIST-LENGTH FUNCTION) 2)
	   (MEMBER (FIRST FUNCTION) '(QUOTE FUNCTION))
	   (SYMBOLP (SECOND FUNCTION)))
      (SETQ FUNCTION (SECOND FUNCTION))
      (FERROR "~S is not a constant function; APPLY of it is~@
	       not understood as a generalized variable" FUNCTION))
  (MULTIPLE-VALUE-BIND (VARS VALS STORE-VARS STORE-FORM ACCESS-FORM)
      (GET-SETF-METHOD-MULTIPLE-VALUE (CONS FUNCTION ARGS))
    (LET ((LIST-VAR (LOOP FOR VAR IN VARS AND VAL IN VALS
			  WHEN (EQ VAL (CAR (LAST ARGS))) RETURN VAR)))
      (OR (AND LIST-VAR
	       (EQ (CAR (LAST ACCESS-FORM)) LIST-VAR)
	       (EQ (CAR (LAST STORE-FORM)) LIST-VAR))
	  (FERROR "APPLY of ~S not understood as a generalized variable" FUNCTION))
      (VALUES VARS VALS STORE-VARS
	      `(APPLY #',(FIRST STORE-FORM) . ,(REST STORE-FORM))
	      `(APPLY #',(FIRST ACCESS-FORM) . ,(REST ACCESS-FORM))))))