(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "18-Oct-86 21:49:21" {eris}<lispcore>sources>cmlsetf.\;10
 34124  

      |previous| |date:| "16-Oct-86 22:26:06" {eris}<lispcore>sources>cmlsetf.\;9)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint cmlsetfcoms)

(rpaqq cmlsetfcoms
 
       ((vars *default-default*)
        (fns cl:get-setf-method get-simple-setf-method)
        (functions cl::get-setf-method-multiple-value)
        (define-types setfs)
        (functions cl:define-modify-macro cl:define-setf-method cl:defsetf)
        (functions cl:incf cl:decf)
        (functions cl:setf cl:psetf cl:shiftf cl:rotatef cl:push cl:pushnew cl:pop cl:remf)
        (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 cl:first cl:second cl:third cl:fourth cl:fifth cl:sixth cl:seventh 
               cl:eighth cl:ninth cl:tenth cl:rest cl:nthcdr cl:nth cl:gethash cl:getf cl:apply ldb 
               cl:mask-field cl:char-bit the)
        (setfs \\getbaseptr gethash)
        (prop filetype cmlsetf)
        (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama)
                                                                             (nlaml)
                                                                             (lama cl:get-setf-method
                                                                                   )))))

(rpaqq *default-default*
 nil)
(defineq

(cl:get-setf-method

  (cl:lambda (form environment)
                              (* |jrb:| "15-Oct-86 17:32")

         (let (temp)
              (cond
                 ((cl:symbolp form)                          (* "The simple variable case;" 

                                                             "turns into a normal SETQ.")

                  (let ((new-var (gensym)))
                       (cl:values nil nil (list new-var)
                              `(cl:setq ,form ,new-var) form)))
                 ((cl:atom form)
                  (cl:error "~S illegal atomic form for GET-SETF-METHOD." form))
                 ((setq temp (or (get (car form)
                                      'setf-inverse)
                                 (get (car form)
                                      'setfn)))              (* "Interlisp's SETFN's are exactly" 

                                                             "like SETF-INVERSE's.")

                  (get-simple-setf-method
 form temp))
                 ((setq temp (get (car form)
                                  'setf-method-expander))
                  (cl:funcall temp form environment))
                 ((setq temp (get (car form)
                                  'crops))                   (* "Interlisp hack for representing" 

                                                             "the C{A|D}*R functions")

                  (cl:get-setf-method
 `(,(pack* 'c (car (last temp))
                                                'r) (,(pack* 'c (substring (car form)
                                                                       3 -1)) ,(cadr form)))))
                 (t (cl:if (eq (setq temp (cl:macroexpand-1 form environment))
                               form)
                           (cl:error "~S is not a known location specifier for SETF." (car form))
                           (cl:get-setf-method
 temp environment)))))))

(get-simple-setf-method

  (lambda (form setf-inverse)
                                (* |lmm| " 7-May-86 23:33")

    (let ((new-var (gensym))
          (vars nil)
          (vals nil))
         (cl:dolist (x (cdr form))
                (cl:push (gensym)
                       vars)
                (cl:push x vals))
         (setq vals (cl:nreverse vals))
         (cl:values vars vals (list new-var)
                `(,setf-inverse ,@vars ,new-var)
                `(,(car form) ,@vars)))))
)
(cl:defun cl::get-setf-method-multiple-value
 (form &optional environment) (cl:get-setf-method form 
                                                                                 environment))

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

(defdefiner cl:define-modify-macro

   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))
        (cl: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))
                  ((cl:symbolp arg)
                   (cl:push arg other-args))
                  (t (cl:push (car arg)
                            other-args))))
        (setq other-args (reverse other-args))
        `(defmacro (\\\,
 name) ($$modify-macro-form ,@lambda-list &environment 
                                      $$modify-macro-environment)
            ,doc-string (cl:multiple-value-bind
                         (dummy-variables cl:values new-value setter getter)
                         (cl:get-setf-method $$modify-macro-form $$modify-macro-environment)
                         (cl:do ((d dummy-variables (cdr d))
                                 (v cl:values (cdr v))
                                 (let-list nil (cons (list (car d)
                                                           (car v))
                                                     let-list)))
                                ((null d)
                                 (cl:push (list (car new-value)
                                                ,(cl:if rest-arg `(list* ',function getter
                                                                         ,@other-args
                                                                         ,rest-arg)
                                                        `(list ',function getter ,@other-args)))
                                        let-list)
                                 `(let* ,(reverse let-list) ,setter)))))
))

(defdefiner cl:define-setf-method

   setfs (name lambda-list &environment env &body body)
         (let ((whole (xcl:pack (list "whole-" name)
                             (cl:symbol-package name)))
               (environment (xcl:pack (list "env-" name)
                                   (cl:symbol-package name)))
               (expander (xcl:pack (list "setf-expander-" name)
                                (cl:symbol-package name))))
              (cl:multiple-value-bind
               (newbody local-decs doc)
               (parse-defmacro lambda-list whole body name env :environment environment :error-string 
                      "Setf expander for ~S cannot be called with ~S args.")
               `(cl:eval-when (eval cl:compile load)
                       (remprop ',name 'setf-inverse)
                       (remprop ',name 'setfn)
                       (cl:defun (\\\,
 expander) (,whole ,environment) ,@local-decs ,newbody)

                       (putprop ',name 'setf-method-expander ',expander)
                       ,@(and doc `((cl:setf (cl:documentation ',name 'cl:setf)
                                           ,doc)))))))

(defdefiner cl:defsetf

   setfs
   (name &rest cl:rest &environment env)
   "Associates a SETF update function or macro with the specified access function or macro"
   (cond
      ((null cl:rest)
       (cl:error "No body for DEFSETF of ~A" name))
      ((cl:symbolp (car cl:rest))
                            (* \; "The short form:")


                                                        (* \; "(defsetf access-fn update-fn [doc])")

       (let ((update-fn (car cl:rest))
             (doc (cadr cl:rest)))
            `(progn (cl:eval-when (load cl:compile eval)
                           (remprop ',name 'setf-method-expander)
                           (putprops ,name setf-inverse ,update-fn))
                    ,@(and doc `((cl:setf (cl:documentation ',name 'cl:setf)
                                        ,doc))))))
      ((and (cl:listp (car cl:rest))
            (cdr cl:rest)
            (cl:listp (cadr cl:rest)))
                       (* \; "The complex form:")


                                                  (* \; 

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

       (destructuring-bind
        (arg-list (store-var . others)
               &body body)
        cl:rest
        (cl:if others (cl: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")
                                (cl:symbol-package name)))
              (expander (xcl:pack (list name "-setf-expander")
                               (cl:symbol-package name))))
             (cl:multiple-value-bind
              (code decls doc)
              (parse-defmacro arg-list whole-var body name env)
              `(progn (cl:eval-when (eval cl:compile load)
                             (remprop ',name 'setf-inverse)
                             (cl:setf (cl:symbol-function ',expander)
                                    (function (lambda (access-form)
                                                (let* ((dummies (mapcar (cdr access-form)
                                                                       (function (lambda (x)
                                                                                   (gensym)))))
                                                       (,whole-var (cons (car access-form)
                                                                         dummies))
                                                       (,store-var (gensym)))
                                                      (cl:values dummies (cdr access-form)
                                                             (list ,store-var)
                                                             ,code
                                                             ,whole-var)))))
                             (putprops ,name setf-method-expander ,expander))
                      ,@(and doc `((cl:setf (cl:documentation ',name 'cl:setf)
                                          ,doc))))))))
      (t (cl:error "Ill-formed DEFSETF for ~S." name))))

(cl:define-modify-macro cl: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.")

(cl:define-modify-macro cl: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.")

(defmacro cl:setf
 (place newvalue &rest others &environment env &aux temp) 
          
          (* * "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.")

 (let ((exp (cond
               ((cl:symbolp place)
                `(setq ,place ,newvalue))
               ((and (cl:symbolp (car place))
                     (setq temp (or (get (car place)
                                         'setf-inverse)
                                    (get (car place)
                                         'setfn))))
                `(,temp ,@(cdr place) ,newvalue))
               (t (cl:multiple-value-bind (dummies vals newvals setter getter)
                         (cl:get-setf-method place env)
                         `(let* (\,@ (|for| d |in| dummies |as| v |in| vals |collect|
                                            (list d v))
                                     (\, (car newvals)
                                         \, newvalue))
                                ,setter)))))
       temp)
      (cond
         (others `(progn ,exp (cl:setf \\\, others)))
         (t exp))))

(defmacro cl: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." (cl:do ((a args (cddr a))
                                  (let-list nil)
                                  (setf-list nil))
                                 ((cl:atom a)
                                  `(let* ,(cl:nreverse let-list) ,@(cl:nreverse setf-list) nil))
                                 (cl:if (cl:atom (cdr a))
                                        (cl:error "Odd number of args to PSETF."))
                                 (cl:multiple-value-bind (dummies vals newval setter getter)
                                        (cl:get-setf-method (car a)
                                               env)
                                        (declare (ignore getter))
                                        (cl:do* ((d dummies (cdr d))
                                                 (v vals (cdr v)))
                                               ((null d))
                                               (cl:push (list (car d)
                                                              (car v))
                                                      let-list))
                                        (cl:push (list (car newval)
                                                       (cadr a))
                                               let-list)
                                        (cl:push setter setf-list))))

(defmacro cl:shiftf
 (&rest args &environment env) "Takes any number of SETF-style place expressions.  Evaluates all of the
  expressions in turn, then assigns to each place the value of the form to
  its right.  The rightmost form is not assigned to. SHIFTF returns the value of the first place before the assignments are made."
   (cond
      ((or (null args)
           (null (cdr args)))
       (cl:error "SHIFTF needs at least two arguments"))
      (t (cl:do ((a args (cdr a))
                 (let-list nil)
                 (setf-list nil)
                 (result (gensym))
                 (next-var nil))
                ((cl:atom (cdr a))
                 (dsubst (car a)
                        next-var
                        (car setf-list))
                 `(let* ,(cl:nreverse let-list) ,@(cl:nreverse setf-list) ,result))
                (cl:multiple-value-bind (dummies vals newval setter getter)
                       (cl:get-setf-method (car a)
                              env)
                       (cl:do ((d dummies (cdr d))
                               (v vals (cdr v)))
                              ((null d))
                              (cl:push (list (car d)
                                             (car v))
                                     let-list))
                       (cl:unless next-var (cl:setq next-var result))
                       (cl:push (list next-var getter)
                              let-list)
                       (cl:push setter setf-list)
                       (setq next-var (car newval)))))))

(defmacro cl:rotatef
 (&rest args &environment env) "Takes any number of SETF-style place expressions.  Evaluates all of the
  expressions in turn, then assigns to each place the value of the form to
  its right.  The rightmost form gets the value of the leftmost.  Returns NIL."
   (cond
      ((null args)
       nil)
      ((null (cdr args))
       `(progn ,(car args) nil))
      (t (cl:do ((a args (cdr a))
                 (let-list nil)
                 (setf-list nil)
                 (next-var nil)
                 (fix-me nil))
                ((cl:atom a)
                 (rplaca fix-me next-var)
                 `(let* ,(cl:nreverse let-list) ,@(cl:nreverse setf-list) nil))
                (cl:multiple-value-bind (dummies vals newval setter getter)
                       (cl:get-setf-method (car a)
                              env)
                       (cl:do ((d dummies (cdr d))
                               (v vals (cdr v)))
                              ((null d))
                              (cl:push (list (car d)
                                             (car v))
                                     let-list))
                       (cl:push (list next-var getter)
                              let-list)
          
          (* w\e |don't| |know| |the| |newval| |variable| |for| |the| |last| |form| 

          |yet,| *)

          
          (* |so| |fake| |it| |for| |the| |first| |getter| |and| |fix| |it| |at| |the| 

          |end.| *)


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

(defmacro cl:push
 (obj place &environment env) "Takes an object and a location holding a list.  Conses the object onto
  the list, returning the modified list."
   (cl:if (cl:symbolp place)
          `(setq ,place (cons ,obj ,place))
          (cl:multiple-value-bind (dummies vals newval setter getter)
                 (cl:get-setf-method place env)
                 (cl:do* ((d dummies (cdr d))
                          (v vals (cdr v))
                          (let-list nil))
                        ((null d)
                         (cl:push (list (car newval)
                                        `(cons ,obj ,getter))
                                let-list)
                         `(let* ,(cl:nreverse let-list) ,setter))
                        (cl:push (list (car d)
                                       (car v))
                               let-list)))))

(defmacro cl:pushnew
 (obj place &rest keys &environment env) "Takes an object and a location holding a list.  If the object is already
  in the list, does nothing.  Else, conses the object onto the list.  Returns
  NIL.  If there is a :TEST keyword, this is used for the comparison."
   (cl:if (cl:symbolp place)
          `(setq ,place (cl:adjoin ,obj ,place ,@keys))
          (cl:multiple-value-bind (dummies vals newval setter getter)
                 (cl:get-setf-method place env)
                 (cl:do* ((d dummies (cdr d))
                          (v vals (cdr v))
                          (let-list nil))
                        ((null d)
                         (cl:push (list (car newval)
                                        `(cl:adjoin ,obj ,getter ,@keys))
                                let-list)
                         `(let* ,(cl:nreverse let-list) ,setter))
                        (cl:push (list (car d)
                                       (car v))
                               let-list)))))

(defmacro cl:pop
 (place &environment env) "The argument is a location holding a list.  Pops one item off the front
  of the list and returns it."
   (cl:if (cl:symbolp place)
          `(prog1 (car ,place)
                  (setq ,place (cdr ,place)))
          (cl:multiple-value-bind (dummies vals newval setter getter)
                 (cl:get-setf-method place env)
                 (cl:do* ((d dummies (cdr d))
                          (v vals (cdr v))
                          (let-list nil))
                        ((null d)
                         (cl:push (list (car newval)
                                        getter)
                                let-list)
                         `(let* ,(cl:nreverse let-list) (prog1 (car ,(car newval))
                                                               (setq ,(car newval)
                                                                (cdr ,(car newval)))
                                                               ,setter)))
                        (cl:push (list (car d)
                                       (car v))
                               let-list)))))

(defmacro cl:remf
 (place indicator &environment env) "Place may be any place expression acceptable to SETF, and is expected to hold a property list or (). This list is destructively altered to remove the property specified by the indicator. Returns T if such a property was present, NIL if not."
   (cl:multiple-value-bind
    (dummies vals newval setter getter)
    (cl:get-setf-method place env)
    (cl:do* ((d dummies (cdr d))
             (v vals (cdr v))
             (let-list nil)
             (ind-temp (gensym))
             (local1 (gensym))
             (local2 (gensym)))
           ((null d)
            (cl:push (list (car newval)
                           getter)
                   let-list)
            (cl:push (list ind-temp indicator)
                   let-list)
            `(let* ,(cl:nreverse let-list) (cl:do ((,local1 ,(car newval) (cddr ,local1))
                                                   (,local2 nil ,local1))
                                                  ((cl:atom ,local1)
                                                   nil)
                                                  (cond
                                                     ((cl:atom (cdr ,local1))
                                                      (cl:error "Odd-length property list in REMF."))
                                                     ((eq (car ,local1)
                                                          ,ind-temp)
                                                      (cond
                                                         (,local2 (rplacd (cdr ,local2)
                                                                         (cddr ,local1))
                                                                (return t))
                                                         (t (cl:setq ,(car newval)
                                                                   (cddr ,(car newval)))
                                                            ,setter
                                                            (return t))))))))
           (cl:push (list (car d)
                          (car v))
                  let-list))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(cl:defsetf cl:nth
 %setnth)

(cl:define-setf-method cl:gethash
 (key hashtable &optional default)
   (let ((key-temp (gensym))
         (hashtable-temp (gensym))
         (default-temp (gensym))
         (new-value-temp (gensym)))
        (cl:values `(,key-temp ,hashtable-temp ,@(cl:if default `(,default-temp)))
               `(,key ,hashtable ,@(cl:if default `(,default)))
               `(,new-value-temp)
               `(cl::puthash ,key-temp ,hashtable-temp ,new-value-temp)
               `(cl:gethash ,key-temp ,hashtable-temp ,@(cl:if default `(,default-temp))))))

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

(cl:define-setf-method cl:apply
 (function &rest args &environment env)
   (cl:if (and (listp function)
               (= (cl:list-length function)
                  2)
               (member (cl:first function)
                      '(function cl:function quote))
               (cl:symbolp (cl:second function)))
          (setq function (cl:second function))
          (cl:error "Setf of Apply is only defined for function args of form #'symbol."))
   (cl:multiple-value-bind (dummies vals newval setter getter)
          (cl:get-setf-method (cons function args)
                 env)
          
          (* |Make| |sure| |the| |place| |is| |one| |that| |we| |can| |handle.|

          *)


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

(cl: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."
   (cl:multiple-value-bind (dummies vals newval setter getter)
          (cl:get-setf-method place env)
          (let ((btemp (gensym))
                (gnuval (gensym)))
               (cl:values (cons btemp dummies)
                      (cons bytespec vals)
                      (list gnuval)
                      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
                            ,setter
                            ,gnuval)
                      `(ldb ,btemp ,getter)))))

(cl:define-setf-method cl: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."
   (cl:multiple-value-bind (dummies vals newval setter getter)
          (cl:get-setf-method place)
          (let ((btemp (gensym))
                (gnuval (gensym)))
               (cl:values (cons btemp dummies)
                      (cons bytespec vals)
                      (list gnuval)
                      `(let ((,(car newval) (cl:deposit-field ,gnuval ,btemp ,getter)))
                            ,setter
                            ,gnuval)
                      `(cl:mask-field ,btemp ,getter)))))

(cl:define-setf-method cl: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."
   (cl:multiple-value-bind (dummies vals newval setter getter)
          (cl:get-setf-method place env)
          (let ((btemp (gensym))
                (gnuval (gensym)))
               (cl:values `(,@dummies ,btemp) `(,@vals ,bit-name) (list gnuval)
                      `(let ((,(car newval) (cl:set-char-bit ,getter ,btemp ,gnuval)))
                            ,setter
                            ,gnuval)
                      `(cl:char-bit ,getter ,btemp)))))

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

(cl:defsetf \\getbaseptr
 \\putbaseptr)

(cl:define-setf-method gethash
 (key hashtable &optional default)
   (let ((key-temp (gensym))
         (hashtable-temp (gensym))
         (default-temp (gensym))
         (new-value-temp (gensym)))
        (cl:values `(,key-temp ,hashtable-temp ,@(cl:if default `(,default-temp)))
               `(,key ,hashtable ,@(cl:if default `(,default)))
               `(,new-value-temp)
               `(puthash ,key-temp ,new-value-temp ,hashtable-temp)
               `(gethash ,key-temp ,hashtable-temp ,@(cl:if default `(,default-temp))))))


(putprops cmlsetf filetype
 cl:compile-file)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 cl:get-setf-method)
)
(putprops cmlsetf copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil (1642 4132 (cl:get-setf-method 1652 . 3624) (get-simple-setf-method 3626 . 4130)))))
stop