(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")

(il:filecreated "13-Jun-90 16:19:18" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLSETF.;6|
 40556  

      il:|changes| il:|to:|  (il:functions get-setf-method)

      il:|previous| il:|date:| "11-Jun-90 15:06:52" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLSETF.;5|
)


; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(il:prettycomprint il:cmlsetfcoms)

(il:rpaqq il:cmlsetfcoms
 
          ((il:functions get-setf-method get-simple-setf-method get-setf-method-multiple-value)
           (il:define-types il:setfs)
           (il:functions defsetf define-modify-macro define-setf-method)
           (il:coms 

                  (il:* il:|;;| "Support for defstruct and friends ")


                  (il:functions define-shared-setf-macro define-shared-setf get-shared-setf-method))
           (il:functions setf setf-error)
           (il:functions psetf shiftf rotatef pop remf)
           (il:functions incf decf)
           (il:functions maybe-make-binding-form count-occurrences)
           (il:functions push pushnew)
           (il:setfs car cdr caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar
                  cadddr caddr cadr cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar
                  cdddar cddddr cdddr cddr first second third fourth fifth sixth seventh eighth ninth
                  tenth rest nthcdr nth getf apply ldb mask-field char-bit the)
           (il:coms                                          (il:* il:\; 

                                                     "Some IL setfs, for no especially good reason")

                  (il:setfs il:gethash)
                  (il:functions il:%set-il-gethash))
           (il:prop il:proptype :setf-method-expander :setf-inverse :shared-setf-inverse)
           (il:prop (il:filetype il:makefile-environment)
                  il:cmlsetf)
           (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars
                                                                                         (il:nlama)
                                                                                         (il:nlaml)
                                                                                         (il:lama)))))

(defun get-setf-method
 (form &optional environment)
   (let (temp)
        (cond
           ((symbolp form)

            (il:* il:|;;| "Symbols have a simple, constant SETF method.")


            (values nil nil (list (setq temp (il:gensym)))
                   `(setq ,form ,temp)
                   form))
           ((not (consp form))                               (il:* il:\; "Syntax error")

            (setf-error form))
           ((setq temp (il:local-macro-function (car form)
                              environment))

            (il:* il:|;;| 

    "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.")


            (get-setf-method (funcall temp form environment)
                   environment))
           ((setq temp (or (get (car form)
                                ':setf-inverse)
                           (get (car form)
                                'il:setf-inverse)
                           (get (car form)
                                'il:setfn)))
            (get-simple-setf-method form temp))
           ((setq temp (get (car form)
                            ':shared-setf-inverse))
            (get-shared-setf-method form temp))
           ((setq temp (or (get (car form)
                                ':setf-method-expander)
                           (get (car form)
                                'il:setf-method-expander)))

            (il:* il:|;;| "Do check number of the Store Variables")


            (multiple-value-bind (temps values stores setter getter)
                   (funcall temp form environment)
                   (when (/= (length stores)
                             1)
                       (warn 
          "SETF method contains more than one store variable. Only top of the elements was accepted."
                             )
                       (setq stores (list (car stores))))
                   (values temps values stores setter getter)))
           (t (multiple-value-bind (expansion done)
                     (macroexpand-1 form environment)
                     (if (and done (not (eq expansion form)))
                         (get-setf-method expansion environment)
                         (setf-error (car form)
                                form)))))))

(defun get-simple-setf-method
 (form setf-inverse)

   (il:* il:|;;| "Produce SETF method for a form that has a setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.")


   (let ((new-var (il:gensym))
         vars vals args setf-inverse-form get-form)
        (setq args (mapcar #'(lambda (arg)
                                    (cond
                                       ((if (consp arg)
                                            (eq (car arg)
                                                'quote)
                                            (constantp arg))

                                 (il:* il:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.")


                                        arg)
                                       (t 
                                          (il:* il:|;;| 

                                       "Anything else might be side-effected, so will need to bind")


                                          (push arg vals)
                                          (let ((g (il:gensym)))
                                               (push g vars)
                                               g))))
                          (cdr form)))
        (setq setf-inverse-form (macroexpand-1 `(,setf-inverse ,@args ,new-var)))
        (setq get-form (macroexpand-1 `(,(car form)
                                        ,@args)))

        (il:* il:|;;| 

      "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions")


        (values (setq vars (nreverse vars))
               (setq vals (nreverse vals))
               (list new-var)
               setf-inverse-form get-form)))

(defun get-setf-method-multiple-value
 (form &optional environment)
   (let (temp)
        (cond
           ((symbolp form)

            (il:* il:|;;| "Symbols have a simple, constant SETF method.")


            (values nil nil (list (setq temp (il:gensym)))
                   `(setq ,form ,temp)
                   form))
           ((not (consp form))                               (il:* il:\; "Syntax error")

            (setf-error form))
           ((setq temp (il:local-macro-function (car form)
                              environment))

            (il:* il:|;;| 

    "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.")


            (get-setf-method (funcall temp form environment)
                   environment))
           ((setq temp (or (get (car form)
                                ':setf-inverse)
                           (get (car form)
                                'il:setf-inverse)
                           (get (car form)
                                'il:setfn)))
            (get-simple-setf-method form temp))
           ((setq temp (get (car form)
                            ':shared-setf-inverse))
            (get-shared-setf-method form temp))
           ((setq temp (or (get (car form)
                                ':setf-method-expander)
                           (get (car form)
                                'il:setf-method-expander)))

            (il:* il:|;;| "Does not check the number of Store Variables.")


            (funcall temp form environment))
           (t (multiple-value-bind (expansion done)
                     (macroexpand-1 form environment)
                     (if (and done (not (eq expansion form)))
                         (get-setf-method expansion environment)
                         (setf-error (car form)
                                form)))))))

(xcl:def-define-type il:setfs
 "Common Lisp SETF definitions")

(xcl:defdefiner (defsetf
 (:prototype (lambda (name)
                                                (and (symbolp name)
                                                     `(defsetf ,name "Inverse function"))))) il:setfs (
                                                                                                 name
                                                                                                       
&rest rest &environment env)

(il:* il:|;;;| 

"Associates a SETF update function or macro with the specified access function or macro")


   (cond
      ((null rest)
       (error "No body for DEFSETF of ~A" name))
      ((and (listp (car rest))
            (cdr rest)
            (listp (cadr rest)))

       (il:* il:|;;| "The complex form:")


       (il:* il:|;;| "(defsetf access-fn args (store-var) {decl | doc}* {form}*)")


       (xcl:destructuring-bind
        (arg-list (store-var &rest others)
               &body body)
        rest
        (if others (cerror "Ignore the extra items in the list." 
                          "Currently only one new-value variable is allowed in DEFSETF."))
        (let
         ((whole-var (xcl:pack (list name "-setf-form")
                            (symbol-package name)))
          (environment (xcl:pack (list name "-setf-env")
                              (symbol-package name)))
          (expander (xcl:pack (list name "-setf-expander")
                           (symbol-package name))))
         (multiple-value-bind
          (code decls doc)
          (il:parse-defmacro arg-list whole-var body name env :environment environment)
          `(progn (eval-when (eval compile load)
                         (setf (symbol-function ',expander)
                               #'(lambda (access-form ,environment)
                                        (let* ((dummies (mapcar #'(lambda (x)
                                                                         (il:gensym))
                                                               (cdr access-form)))
                                               (,whole-var (cons (car access-form)
                                                                 dummies))
                                               (,store-var (il:gensym)))
                                              (values dummies (cdr access-form)
                                                     (list ,store-var)
                                                     (block ,name ,code)
                                                     ,whole-var))))
                         (set-setf-method-expander ',name ',expander))
                  ,@(and doc `((setf (documentation ',name 'setf)
                                     ,doc))))))))
      ((symbolp (car rest))

       (il:* il:|;;| "The short form:")


       (il:* il:|;;| "(defsetf access-fn update-fn [doc])")


       (let ((update-fn (car rest))
             (doc (cadr rest)))
            `(progn (eval-when (load compile eval)
                           (set-setf-inverse ',name ',update-fn))
                    ,@(and doc `((setf (documentation ',name 'setf)
                                       ,doc))))))
      (t (error "Ill-formed DEFSETF for ~S." name))))

(xcl:defdefiner (define-modify-macro
 (:prototype (lambda (name)
                                                            (and (symbolp name)
                                                                 `(define-modify-macro ,name ,@(
                                                                        xcl::%make-function-prototype
                                                                                                ))))))
 il:functions (name lambda-list function &optional doc-string)
   "Creates a new read-modify-write macro like PUSH or INCF."
   (let ((other-args nil)
         (rest-arg nil))
        (do ((ll lambda-list (cdr ll))
             (arg nil))
            ((null ll))
          (setq arg (car ll))
          (cond
             ((eq arg '&optional))
             ((eq arg '&rest)
              (setq rest-arg (cadr ll))
              (return nil))
             ((symbolp arg)
              (push arg other-args))
             (t (push (car arg)
                      other-args))))
        (setq other-args (nreverse other-args))
        `(defmacro ,name (si::%$$modify-macro-form ,@lambda-list &environment 
                                si::%$$modify-macro-environment)
            ,doc-string (multiple-value-bind
                         (dummies vals newvals setter getter)
                         (get-setf-method si::%$$modify-macro-form si::%$$modify-macro-environment)
                         `(,'let* (,@(mapcar #'list dummies vals)
                                   (,(car newvals)
                                    ,,(if rest-arg
                                          `(list* ',function getter ,@other-args ,rest-arg)
                                          `(list ',function getter ,@other-args))))
                                 ,setter)))))

(xcl:defdefiner (define-setf-method
 (:prototype (lambda (name)
                                                           (and (symbolp name)
                                                                `(define-setf-method ,name (
                                                                                           "Arg list"
                                                                                            ) "Body")
                                                                )))) il:setfs (name lambda-list 
                                                                                    &environment env
                                                                                    &body body)
   (let ((whole (xcl:pack (list "whole-" name)
                       (symbol-package name)))
         (environment (xcl:pack (list "env-" name)
                             (symbol-package name)))
         (expander (xcl:pack (list "setf-expander-" name)
                          (symbol-package name))))
        (multiple-value-bind (newbody local-decs doc)
               (il:parse-defmacro lambda-list whole body name env :environment environment 
                      :error-string "Setf expander for ~S cannot be called with ~S args.")
               `(eval-when (eval compile load)
                       (defun ,expander (,whole ,environment)
                          ,@local-decs (block ,name ,newbody))
                       (set-setf-method-expander ',name ',expander)
                       ,@(and doc `((setf (documentation ',name 'setf)
                                          ,doc)))))))



(il:* il:|;;| "Support for defstruct and friends ")



(xcl:defdefiner define-shared-setf-macro
 il:functions (name accessor arg-list store-var &body 
                                                                body &environment env)

(il:* il:|;;;| 

"Defines a shared SETF update function for a family of accessores -- used by defstruct")


   (if (not (and (consp store-var)
                 (eq 1 (length store-var))))
       (error "Store-var should be a list of one element: ~s" store-var))
   (multiple-value-bind (code decls doc)
          (xcl:parse-body body env t)
          `(defmacro ,name (,accessor ,@arg-list ,@store-var)
              ,@doc ,@decls ,@code)))

(xcl:defdefiner define-shared-setf
 il:setfs (name shared-expander &optional doc)

(il:* il:|;;;| 

"Associates a shared SETF update macro with the specified accessor function -- used by defstruct")


   `(progn (eval-when (load compile eval)
                  (set-shared-setf-inverse ',name ',shared-expander))
           ,@(and doc `((setf (documentation ',name 'setf)
                              ,doc)))))

(defun get-shared-setf-method
 (form shared-setf-inverse)

   (il:* il:|;;| "Produce SETF method for a form that has a shared-setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.")


   (let ((new-var (il:gensym))
         vars vals args shared-setf-inverse-form get-form)
        (setq args (mapcar #'(lambda (arg)
                                    (cond
                                       ((if (consp arg)
                                            (eq (car arg)
                                                'quote)
                                            (constantp arg))

                                 (il:* il:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.")


                                        arg)
                                       (t 
                                          (il:* il:|;;| 

                                       "Anything else might be side-effected, so will need to bind")


                                          (push arg vals)
                                          (let ((g (il:gensym)))
                                               (push g vars)
                                               g))))
                          (cdr form)))
        (setq shared-setf-inverse-form (macroexpand-1 `(,shared-setf-inverse ,(car form)
                                                              ,@args
                                                              ,new-var)))
        (setq get-form (macroexpand-1 `(,(car form)
                                        ,@args)))

        (il:* il:|;;| 

      "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions")


        (values (setq vars (nreverse vars))
               (setq vals (nreverse vals))
               (list new-var)
               shared-setf-inverse-form get-form)))

(defmacro setf
 (place new-value &rest others &environment env)

(il:* il:|;;;| "Takes pairs of arguments like SETQ. The first is a place and the second is the value that is supposed to go into that place. Returns the last value. The place argument may be any of the access forms for which SETF knows a corresponding setting form.")


(il:* il:|;;;| "We short-circuit the normal SETF-method mechanism for two very common special cases, so as to produce much simpler and more efficient code.  The two cases are symbols and forms with simple inverses.")


   (cond
      (others `(progn (setf ,place ,new-value)
                      (setf ,@others)))
      (t (prog (temp)
           lp  (cond
                  ((symbolp place)
                   (return `(setq ,place ,new-value)))
                  ((not (consp place))
                   (setf-error place))
                  ((setq temp (il:local-macro-function (car place)
                                     env))

                   (il:* il:|;;| "Before looking for an inverse, we have to macroexpand until it isn't a reference to a lexical macro, since those can't have SETF methods.")


                   (setq place (funcall temp place env)))
                  ((and (symbolp (car place))
                        (setq temp (or (get (car place)
                                            ':setf-inverse)
                                       (get (car place)
                                            'il:setf-inverse)
                                       (get (car place)
                                            'il:setfn))))
                   (return `(,temp ,@(cdr place)
                                   ,new-value)))
                  ((and (symbolp (car place))
                        (setq temp (get (car place)
                                        ':shared-setf-inverse)))
                   (return `(,temp ,(car place)
                                   ,@(cdr place)
                                   ,new-value)))
                  ((or (get (car place)
                            ':setf-method-expander)
                       (get (car place)
                            'il:setf-method-expander))

                   (il:* il:|;;| "General setf hair")


                   (return (multiple-value-bind (dummies vals newvals setter getter)
                                  (get-setf-method place env)
                                  `(,'let* (,@(mapcar #'list dummies vals)
                                            (,(car newvals)
                                             ,new-value))
                                          ,setter))))
                  (t                                         (il:* il:\; "Try macro expanding")

                     (multiple-value-bind (expansion done)
                            (macroexpand-1 place env)
                            (cond
                               ((and done (not (eq expansion place)))
                                (setq place expansion))
                               (t (return (setf-error (car place)
                                                 place)))))))
               (go lp)))))

(defun setf-error
 (fn &optional form)

   (il:* il:|;;| "Common error routine for invalid SETF's.  FN is the thing we tried to find a setf method for, FORM is its parent (not supplied when the form is a non-list).")


   (error "~S is not a known location specifier for SETF." fn))

(defmacro psetf
 (&rest args &environment env)
   "This is to SETF as PSETQ is to SETQ.  Args are alternating place
  expressions and values to go into those places.  All of the subforms and
  values are determined, left to right, and only then are the locations
  updated.  Returns NIL."
   (do ((a args (cddr a))
        (let-list nil)
        (setf-list nil))
       ((atom a)
        `(,'let ,(reverse let-list)
                ,@(reverse setf-list)
                nil))
     (if (atom (cdr a))
         (error "Odd number of args to PSETF."))
     (multiple-value-bind (dummies vals newval setter getter)
            (get-setf-method (car a)
                   env)
            (declare
 (ignore getter))
            (do* ((d dummies (cdr d))
                  (v vals (cdr v)))
                 ((null d))
               (push (list (car d)
                           (car v))
                     let-list))
            (push (list (car newval)
                        (cadr a))
                  let-list)
            (push setter setf-list))))

(defmacro shiftf
 (&rest args &environment env)
   "Assigns to each place the value of the form to its right, returns old value of 1st"
   (cond
      ((or (null args)
           (null (cdr args)))
       (error "SHIFTF needs at least two arguments"))
      (t (do* ((a args (cdr a))
               (let-list nil)
               (setf-list nil)
               (result (il:gensym))
               (next-var result))
              ((atom (cdr a))
               (push (list next-var (car a))
                     let-list)
               `(,'let* ,(reverse let-list)
                       ,@(reverse setf-list)
                       ,result))
            (multiple-value-bind (dummies vals newval setter getter)
                   (get-setf-method (car a)
                          env)
                   (do ((d dummies (cdr d))
                        (v vals (cdr v)))
                       ((null d))
                     (push (list (car d)
                                 (car v))
                           let-list))
                   (push (list next-var getter)
                         let-list)
                   (push setter setf-list)
                   (setq next-var (car newval)))))))

(defmacro rotatef
 (&rest args &environment env)
   "Assigns to each place the value of the form to its right; last gets first. Returns NIL."

   (il:* il:|;;| "forms evaluated in order")


   (cond
      ((null args)
       nil)
      ((null (cdr args))
       `(progn ,(car args)
               nil))
      (t (do ((a args (cdr a))
              (let-list nil)
              (setf-list nil)
              (next-var nil)
              (fix-me nil))
             ((atom a)
              (rplaca fix-me next-var)
              `(,'let* ,(reverse let-list)
                      ,@(reverse setf-list)
                      nil))
           (multiple-value-bind (dummies vals newval setter getter)
                  (get-setf-method (car a)
                         env)
                  (do ((d dummies (cdr d))
                       (v vals (cdr v)))
                      ((null d))
                    (push (list (car d)
                                (car v))
                          let-list))
                  (push (list next-var getter)
                        let-list)

                  (il:* il:|;;| "We don't know the newval variable for the last form yet,so fake it for the first getter and fix it at the end.")


                  (unless fix-me
                      (setq fix-me (car let-list)))
                  (push setter setf-list)
                  (setq next-var (car newval)))))))

(defmacro pop
 (place &environment env)
   "Pops one item off the front of PLACE and returns it."
   (if (symbolp place)
       `(prog1 (car ,place)
            (setq ,place (cdr ,place)))
       (multiple-value-bind (dummies vals newval setter getter)
              (get-setf-method place env)
              `(,'let* (,@(mapcar #'list dummies vals)
                        ,(list (car newval)
                               getter))
                      (prog1 (car ,(car newval))
                          (setq ,(car newval)
                                (cdr ,(car newval)))
                          ,setter)))))

(defmacro remf
 (place indicator &environment env)
   "Destructively remove INDICATOR from PLACE, returning T if it was present, NIL if not"
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method place env)
          (let ((ind-temp (il:gensym))
                (local1 (il:gensym))
                (local2 (il:gensym)))
               `(,'let* (,@(mapcar #'list dummies vals)
                         (,(car newval)
                          ,getter)
                         (,ind-temp ,indicator))
                       (do ((,local1 ,(car newval)
                                   (cddr ,local1))
                            (,local2 nil ,local1))
                           ((atom ,local1)
                            nil)
                         (cond
                            ((atom (cdr ,local1))
                             (error "Odd-length property list in REMF."))
                            ((eq (car ,local1)
                                 ,ind-temp)
                             (cond
                                (,local2 (rplacd (cdr ,local2)
                                                (cddr ,local1))
                                       (return t))
                                (t (setq ,(car newval)
                                         (cddr ,(car newval)))
                                   ,setter
                                   (return t))))))))))

(define-modify-macro incf
 (&optional (delta 1)) +
   "The first argument is some location holding a number.  This number is
  incremented by the second argument, DELTA, which defaults to 1.")

(define-modify-macro decf
 (&optional (delta 1)) -
   "The first argument is some location holding a number.  This number is
  decremented by the second argument, DELTA, which defaults to 1.")

(defun maybe-make-binding-form
 (newval-form dummies vals newvar setter getter)

   (il:* il:|;;| "For use in SETF-like forms to produce their final expression without using the NEWVAR gensym where possible.  DUMMIES thru GETTER are the five values returned from the SETF method.  NEWVAL-FORM is an expression to which the (sole) NEWVAR is logically to be bound, written in terms of the GETTER form.  If it looks like there are no side-effect problems, we substitute NEWVAL-FORM into SETTER; otherwise we return a binding form that returns SETTER correctly.")


   (if (or dummies (> (count-occurrences (car newvar)
                             setter)
                      1))                                    (il:* il:\; 

                                                           " have to do messy binding form")

       `(,'let* (,@(mapcar #'list dummies vals)
                 (,(car newvar)
                  ,newval-form))
               ,setter)                                      (il:* il:\; 

       "No temp vars, setter used only once, so nothing can be side-effected, so store it directly")

       (subst newval-form (car newvar)
              setter)))

(defun count-occurrences
 (symbol form)
   (cond
      ((consp form)
       (+ (count-occurrences symbol (car form))
          (count-occurrences symbol (cdr form))))
      ((eq symbol form)
       1)
      (t 0)))

(defmacro push
 (obj place &environment env)
   "Conses OBJ onto PLACE, returning the modified list."
   (if (symbolp place)
       `(setq ,place (cons ,obj ,place))
       (multiple-value-bind (dummies vals newval setter getter)
              (get-setf-method place env)
              (maybe-make-binding-form `(cons ,obj ,getter)
                     dummies vals newval setter getter))))

(defmacro pushnew
 (obj place &rest keys &environment env)
   "Conses OBJ onto PLACE unless its already there, using :TEST if necessary"
   (if (symbolp place)
       `(setq ,place (adjoin ,obj ,place ,@keys))
       (multiple-value-bind (dummies vals newval setter getter)
              (get-setf-method place env)
              (maybe-make-binding-form `(adjoin ,obj ,getter ,@keys)
                     dummies vals newval setter getter))))

(defsetf car
 (x) (v)
   `(car (rplaca ,x ,v)))

(defsetf cdr
 (x) (v)
   `(cdr (rplacd ,x ,v)))

(defsetf caaaar
 (x) (v)
   `(car (rplaca (caaar ,x)
                ,v)))

(defsetf caaadr
 (x) (v)
   `(car (rplaca (caadr ,x)
                ,v)))

(defsetf caaar
 (x) (v)
   `(car (rplaca (caar ,x)
                ,v)))

(defsetf caadar
 (x) (v)
   `(car (rplaca (cadar ,x)
                ,v)))

(defsetf caaddr
 (x) (v)
   `(car (rplaca (caddr ,x)
                ,v)))

(defsetf caadr
 (x) (v)
   `(car (rplaca (cadr ,x)
                ,v)))

(defsetf caar
 (x) (v)
   `(car (rplaca (car ,x)
                ,v)))

(defsetf cadaar
 (x) (v)
   `(car (rplaca (cdaar ,x)
                ,v)))

(defsetf cadadr
 (x) (v)
   `(car (rplaca (cdadr ,x)
                ,v)))

(defsetf cadar
 (x) (v)
   `(car (rplaca (cdar ,x)
                ,v)))

(defsetf caddar
 (x) (v)
   `(car (rplaca (cddar ,x)
                ,v)))

(defsetf cadddr
 (x) (v)
   `(car (rplaca (cdddr ,x)
                ,v)))

(defsetf caddr
 (x) (v)
   `(car (rplaca (cddr ,x)
                ,v)))

(defsetf cadr
 (x) (v)
   `(car (rplaca (cdr ,x)
                ,v)))

(defsetf cdaaar
 (x) (v)
   `(cdr (rplacd (caaar ,x)
                ,v)))

(defsetf cdaadr
 (x) (v)
   `(cdr (rplacd (caadr ,x)
                ,v)))

(defsetf cdaar
 (x) (v)
   `(cdr (rplacd (caar ,x)
                ,v)))

(defsetf cdadar
 (x) (v)
   `(cdr (rplacd (cadar ,x)
                ,v)))

(defsetf cdaddr
 (x) (v)
   `(cdr (rplacd (caddr ,x)
                ,v)))

(defsetf cdadr
 (x) (v)
   `(cdr (rplacd (cadr ,x)
                ,v)))

(defsetf cdar
 (x) (v)
   `(cdr (rplacd (car ,x)
                ,v)))

(defsetf cddaar
 (x) (v)
   `(cdr (rplacd (cdaar ,x)
                ,v)))

(defsetf cddadr
 (x) (v)
   `(cdr (rplacd (cdadr ,x)
                ,v)))

(defsetf cddar
 (x) (v)
   `(cdr (rplacd (cdar ,x)
                ,v)))

(defsetf cdddar
 (x) (v)
   `(cdr (rplacd (cddar ,x)
                ,v)))

(defsetf cddddr
 (x) (v)
   `(cdr (rplacd (cdddr ,x)
                ,v)))

(defsetf cdddr
 (x) (v)
   `(cdr (rplacd (cddr ,x)
                ,v)))

(defsetf cddr
 (x) (v)
   `(cdr (rplacd (cdr ,x)
                ,v)))

(defsetf first
 (x) (v)
   `(car (rplaca ,x ,v)))

(defsetf second
 (x) (v)
   `(car (rplaca (cdr ,x)
                ,v)))

(defsetf third
 (x) (v)
   `(car (rplaca (cddr ,x)
                ,v)))

(defsetf fourth
 (x) (v)
   `(car (rplaca (cdddr ,x)
                ,v)))

(defsetf fifth
 (x) (v)
   `(car (rplaca (cddddr ,x)
                ,v)))

(defsetf sixth
 (x) (v)
   `(car (rplaca (cdr (cddddr ,x))
                ,v)))

(defsetf seventh
 (x) (v)
   `(car (rplaca (cddr (cddddr ,x))
                ,v)))

(defsetf eighth
 (x) (v)
   `(car (rplaca (cdddr (cddddr ,x))
                ,v)))

(defsetf ninth
 (x) (v)
   `(car (rplaca (cddddr (cddddr ,x))
                ,v)))

(defsetf tenth
 (x) (v)
   `(car (rplaca (cdr (cddddr (cddddr ,x)))
                ,v)))

(defsetf rest
 (x) (v)
   `(cdr (rplacd ,x ,v)))

(defsetf nthcdr
 (n list) (newval)
   `(cdr (rplacd (nthcdr (1- ,n)
                        ,list)
                ,newval)))

(defsetf nth
 %set-nth)

(define-setf-method getf
 (place prop &optional default &environment env) 
   (multiple-value-bind
    (temps values stores set get)
    (get-setf-method place env)
    (let ((newval (il:gensym))
          (ptemp (il:gensym))
          (def-temp (il:gensym)))
         (values `(,@temps ,(car stores)
                         ,ptemp
                         ,@(if default
                               `(,def-temp)))
                `(,@values ,get ,prop ,@(if default
                                            `(,default)))
                `(,newval)
                `(cond
                    ((null ,(car stores))
                     (let* ,(list (append stores `((list ,ptemp ,newval))))
                           ,set)
                     ,newval)
                    (t (il:listput ,(car stores)
                              ,ptemp
                              ,newval)))
                `(getf ,(car stores)
                       ,ptemp
                       ,@(if default
                             `(,def-temp)))))))

(define-setf-method apply
 (fn &rest args &environment env) 
   (if (and (consp fn)
            (eq (length fn)
                2)
            (member (first fn)
                   '(function il:function quote)
                   :test
                   #'eq)
            (symbolp (second fn)))
       (setq fn (second fn))
       (error "Setf of Apply is only defined for function args of form #'symbol."))
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method (cons fn args)
                 env)

          (il:* il:|;;| "Make sure the place is one that we can handle.")


          (unless (and (eq (car (last args))
                           (car (last vals)))
                       (eq (car (last getter))
                           (car (last dummies)))
                       (eq (car (last setter))
                           (car (last dummies))))
                 (error "Apply of ~S not understood as a location for Setf." fn))
          (values dummies vals newval `(apply #',(car setter)
                                              ,@(cdr setter))
                 `(apply #',(car getter)
                         ,@(cdr getter)))))

(define-setf-method ldb
 (bytespec place &environment env) 
   "The first argument is a byte specifier.  The second is any place form
  acceptable to SETF.  Replaces the specified byte of the number in this
  place with bits from the low-order end of the new value."
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method place env)
          (let ((btemp (il:gensym))
                (gnuval (il:gensym)))
               (values (cons btemp dummies)
                      (cons bytespec vals)
                      (list gnuval)
                      `(let ((,(car newval)
                              (dpb ,gnuval ,btemp ,getter)))
                            ,setter
                            ,gnuval)
                      `(ldb ,btemp ,getter)))))

(define-setf-method mask-field
 (bytespec place &environment env) 
   "The first argument is a byte specifier.  The second is any place form
  acceptable to SETF.  Replaces the specified byte of the number in this place
  with bits from the corresponding position in the new value."
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method place)
          (let ((btemp (il:gensym))
                (gnuval (il:gensym)))
               (values (cons btemp dummies)
                      (cons bytespec vals)
                      (list gnuval)
                      `(let ((,(car newval)
                              (deposit-field ,gnuval ,btemp ,getter)))
                            ,setter
                            ,gnuval)
                      `(mask-field ,btemp ,getter)))))

(define-setf-method char-bit
 (place bit-name &environment env) 
   "The first argument is any place form acceptable to SETF.  Replaces the
  specified bit of the character in this place with the new value."
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method place env)
          (let ((btemp (il:gensym))
                (gnuval (il:gensym)))
               (values `(,@dummies ,btemp)
                      `(,@vals ,bit-name)
                      (list gnuval)
                      `(let ((,(car newval)
                              (set-char-bit ,getter ,btemp ,gnuval)))
                            ,setter
                            ,gnuval)
                      `(char-bit ,getter ,btemp)))))

(define-setf-method the
 (type place &environment env) 
   (multiple-value-bind (dummies vals newval setter getter)
          (get-setf-method place env)
          (values dummies vals newval (subst `(the ,type ,(car newval))
                                             (car newval)
                                             setter)
                 `(the ,type ,getter))))



(il:* il:\; "Some IL setfs, for no especially good reason")



(defsetf il:gethash
 il:%set-il-gethash)

(defmacro il:%set-il-gethash
 (key hash-table &optional newvalue)

   (il:* il:|;;| "SETF inverse for IL:GETHASH.  Tricky parts are that args to IL:PUTHASH are in wrong order, and IL:GETHASH might default its second arg (yuck, let's flush that), in which case the third arg is absent and the second is the new value.")


   (cond
      ((not newvalue)                                        (il:* il:\; "Defaulted hash table")

       `(il:puthash ,key ,hash-table))
      ((or (il:constantexpressionp newvalue)
           (and (symbolp newvalue)
                (symbolp hash-table)))                       (il:* il:\; "Ok to swap args")

       `(il:puthash ,key ,newvalue ,hash-table))
      (t `(let (il:$$gethash-table)
               (declare
 (il:localvars il:$$gethash-table))
               (il:puthash ,key (progn (il:setq il:$$gethash-table ,hash-table)
                                       ,newvalue)
                      il:$$gethash-table)))))

(il:putprops :setf-method-expander il:proptype
 ignore)

(il:putprops :setf-inverse il:proptype
 ignore)

(il:putprops :shared-setf-inverse il:proptype
 ignore)

(il:putprops il:cmlsetf il:filetype
 :compile-file)

(il:putprops il:cmlsetf il:makefile-environment
 (:readtable "XCL" :package "LISP"))
(il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars 

(il:addtovar il:nlama
 )

(il:addtovar il:nlaml
 )

(il:addtovar il:lama
 )
)
(il:putprops il:cmlsetf il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop