home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / setf / setf.el < prev    next >
Encoding:
Text File  |  1992-04-22  |  23.4 KB  |  617 lines
  1. ;;; $Header: /home/user3/miles/src/elisp/RCS/setf.el,v 1.20 1992/04/21 19:17:28 miles Exp $
  2. ;;; ----------------------------------------------------------------
  3. ;;; setf.el -- Setf for elisp
  4. ;;; Copyright (C) April 1992, Miles Bader <miles@cogsci.ed.ac.uk>
  5. ;;; ----------------------------------------------------------------
  6. ;;; This program is free software; you can redistribute it and/or modify
  7. ;;; it under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2 of the License, or
  9. ;;; (at your option) any later version.
  10. ;;;
  11. ;;; This program is distributed in the hope that it will be useful,
  12. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with this program; if not, write to the Free Software
  18. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19. ;;; ----------------------------------------------------------------
  20. ;;;
  21. ;;; Implements most of the common-lisp setf functions (however, e.g.,
  22. ;;; lists are returned instead of multiple-values, and only a single store
  23. ;;; variable is ever used, since we don't have multiple-values).
  24. ;;;
  25. ;;; The major functions defined are:
  26. ;;;   setf, psetf, shiftf, rotatef, push, pop, incf, decf, swapf (macros)
  27. ;;;   defsetf (macro)
  28. ;;;   define-setf-method (macro)
  29. ;;;   define-modify-macro (macro)
  30. ;;;   get-setf-method
  31. ;;;
  32. ;;; See the end of the file for examples, and "Common Lisp: The Language"
  33. ;;; (Steele) for more complete documentation.
  34. ;;;
  35. ;;; Some non-standard macros defined:
  36. ;;;   setf-update-form makes some common setf definitions easier to write.
  37. ;;;   with-setf-method is just syntactic sugar for binding the result of
  38. ;;;     get-setf-method.
  39. ;;;   defsetf-and-return is like the short-form of defsetf, but arranges for
  40. ;;;    the new-value to be returned; this is for things who's update-function
  41. ;;;     has the right argument order, but doesn't return the right value.
  42. ;;;
  43. ;;; Because of the let-optimizer, the resulting code is pretty reasonable, e.g.
  44. ;;;   (rotatef (car x) (cdr x))  ;; swap the car and cdr of x
  45. ;;;  ==> (let* ((G676 (car x))) (setcar x (cdr x)) (setcdr x G676) nil)
  46. ;;;
  47. ;;; **NOTE** Setf depends on two non-standard elisp packages:
  48. ;;;   * Jamie Zawinski's optimizing byte compiler, for the eval-and-compile
  49. ;;;    special-form.
  50. ;;;   * Rick Sladkey's backquote package (or rather, it doesn't work with the
  51. ;;;     standard backquote implementation that comes with emacs, since that has
  52. ;;;     all sorts of bugs).
  53. ;;;
  54. ;;; It also uses gensym.el and letopt.el, which should be provided.
  55. ;;;
  56. ;;; An example of using define-setf-method is provided in plist.el.
  57. ;;;
  58. ;;; Setf has to autoload things itself, before macroexpanding, since a form's
  59. ;;; setf definition and the setf definition of its macroexpansion may be
  60. ;;; different.
  61. ;;;
  62. ;;; Setf will autoload anything who's fifth arg to autoload was non-NIL,
  63. ;;; indicating a macro; we're going to try macroexpand next anyway, so this
  64. ;;; doesn't do anything horrible.  If there isn't really any macroexpansion,
  65. ;;; for the given function, only a setf definition, you should probably make
  66. ;;; this some indicative non-NIL value like 'SETF.  If something has both a
  67. ;;; setf definition and normal function value, maybe something like 'ALSO-SETF.
  68. ;;;
  69.  
  70. (provide 'setf)
  71.  
  72. (require 'backquote)
  73. (require 'gensym)
  74. (require 'letopt)            ; optimize let bindings
  75.  
  76. ;;; This is needed for setf definition forms to be properly evaluated at
  77. ;;; compile time.  It comes from Jamie Zawinski's byte-compiler.
  78. (autoload 'eval-and-compile "bytecomp" nil nil t)
  79.  
  80. ;;; The proper environment to use while compiling.  It's nil otherwise,
  81. ;;; and so doesn't cause any problems.
  82. (defvar byte-compile-macro-environment)
  83.  
  84. ;;; ----------------------------------------------------------------
  85.  
  86. (defun %setf-gensyms (num)
  87.   (if (zerop num)
  88.       nil
  89.       (cons (gensym) (%setf-gensyms (1- num)))))
  90.  
  91. (defun %setf-zip (x y)
  92.   (and x
  93.        (cons (list (car x) (car y))
  94.          (%setf-zip (cdr x) (cdr y)))))
  95.  
  96. (defun has-setf-method-p (place-form)
  97.   "Returns T if PLACE-FORM has a setf-method.
  98.  
  99. See get-setf-method for more information about setf-methods."
  100.   (or (and (symbolp place-form) form)
  101.       (and (not (atom place-form))
  102.        (let ((fun (car place-form)))
  103.          (or (get fun 'setf-update-fun)
  104.          (get fun 'setf-method))))))
  105.  
  106. (defun %get-setf-simple-update-fun (place-form)
  107.   (cond ((symbolp place-form)
  108.      'setq)
  109.     (t
  110.      (get (car place-form) 'setf-update-fun))))
  111.  
  112. ;;; Try autoloading the function in form (see comment at start of file for
  113. ;;; explanation of why setf autoloads things itself).
  114. (defun %setf-try-autoloading (form original-form)
  115.   (and (listp form)
  116.        (atom (car form))
  117.        (fboundp (car form))
  118.        (let ((func (symbol-function (car form))))
  119.      (and (listp func)
  120.           (eq (car func) 'autoload)
  121.           (nth 4 func)
  122.           (if (or (not (load (nth 1 func) t))
  123.               (eq (symbol-function (car form)) func))
  124.           (error "Autoload of %s failed" (car form))
  125.           (%setfable-form-or-lose form original-form))))))
  126.  
  127. (defun %setf-try-macroexpanding (form original-form)
  128.   (let ((expanded-form
  129.      (macroexpand form byte-compile-macro-environment)))
  130.     (and (not (equal form expanded-form))
  131.      (%setfable-form-or-lose expanded-form
  132.                  (or original-form form)))))
  133.  
  134. (defun %setfable-form-or-lose (form &optional original-form)
  135.   (if (has-setf-method-p form)
  136.       form
  137.       (or (%setf-try-autoloading form original-form)
  138.       (%setf-try-macroexpanding form original-form)
  139.       (error "Form has no setf method: %s" (or original-form form)))))
  140.  
  141. (defmacro with-setf-method (vars place-form &rest body)
  142.   "(with-setf-method VARLIST PLACE-FORM BODY...) binds the variables in
  143. VARLIST to the various components of the setf-method for PLACE-FORM and
  144. evaluates the BODY forms.
  145.  
  146. See get-setf-method for a description of what a setf-method contains."
  147.   (` (apply
  148.       (function (lambda (, vars) (,@ body)))
  149.       (get-setf-method (, place-form)))))
  150.  
  151. ;;; This is much more complicated looking that it really is...
  152. (defmacro setf-update-form (params &rest body)
  153.   "(setf-update-form (OLD-VALUE-VAR PLACE-FORM [RETURN-VALUE]) BODY...)
  154. evaluates the BODY forms to produce a form that will generate a new
  155. value for the place.  The resulting generated forms will always be evaluated
  156. *after* any arguments to the place-forms are evaluated.
  157. OLD-VALUE-VAR should be either NIL, or a symbol, in which case it is
  158. bound to a symbol that will be bound during the evaluation of the generated
  159. form to the old value of PLACE-FORM.  RETURN-VALUE, if supplied, should
  160. evaluate to a form that will form the return value.  The resulting form is
  161. always evaluated *after* any other forms are (and the value of OLD-VALUE-VAR
  162. is still bound).  By default, the new-value of the place is returned.
  163.  
  164.  [does this sound confusing?  It's really not...]
  165.  
  166. Examples:
  167.   (defmacro ++ (place)
  168.     (setf-update-form (old place)
  169.        (` (+ (, old) 1))))
  170.   (defmacro pop (place)
  171.     (setf-update-form (old place (` (car (, old))))
  172.       (` (cdr (, old)))))"
  173.   (let ((old-value-form-var (car params))
  174.     (place-form-form (car (cdr params)))
  175.     (place-form-var (gensym))
  176.     (update-fun-var (gensym))
  177.     (ret-val-form (car (cdr (cdr params)))))
  178.     (` (let* (((, place-form-var)
  179.            (%setfable-form-or-lose (, place-form-form)))
  180.           ((, update-fun-var)
  181.            (%get-setf-simple-update-fun (, place-form-var))))
  182.      (let* ((,@ (and old-value-form-var
  183.              (` ((old-value-var (gensym))
  184.                  ((, old-value-form-var)
  185.                   old-value-var))))))
  186.        (if (, (and (not ret-val-form)
  187.                (` (and (, update-fun-var)
  188.                    (, (if old-value-form-var
  189.                       (` (atom (, place-form-var)))
  190.                       t))))))
  191.            ;; We can use a simple update-function (which avoids generating
  192.            ;; lots of temporary variables).
  193.            (append (list (, update-fun-var))
  194.                (if (atom (, place-form-var))
  195.                (list (, place-form-var))
  196.                (cdr (, place-form-var)))
  197.                (list
  198.             (, (if old-value-form-var
  199.                    (` (` (maybe-let (((, old-value-var)
  200.                           (, (, place-form-var))))
  201.                        (, (,@ body)))))
  202.                    (letopt-maybe-progn body)))))
  203.            ;; We have to use the more general method...
  204.            (with-setf-method (temps val-forms store-vars
  205.                                   store-form access-form)
  206.            (, place-form-var)
  207.          (` (maybe-let* ((,@ (%setf-zip temps val-forms))
  208.                  (,@ (, (and old-value-form-var
  209.                          (` (list
  210.                          (list old-value-var
  211.                                access-form))))))
  212.                  ((, (car store-vars))
  213.                   (, (, (letopt-maybe-progn body)))))
  214.                (, store-form)
  215.                (,@ (, (and ret-val-form
  216.                    (` (list (, ret-val-form))))))))))
  217.        )))))
  218.  
  219. (defun get-setf-method (place-form)
  220.   "Returns the `setf method' for the setf'able form PLACE-FORM.
  221.  
  222. A setf method is a list with the following elements:
  223.  1.  A list of temp-variables to hold argument values.
  224.  2.  A list of value-forms (subforms of PLACE-FORM) to whose values the
  225.      temp-variables are to be bound.
  226.  3.  A list of temporary variables, called store-variables, to hold the new values
  227.      (this is always of length 1, as elisp doesn't have multiple values)
  228.  4.  A `store-form,' which, assuming the above temporary variables are bound,
  229.      will store the new value into the correct place, and return it.
  230.  5.  An `access-form,' which, assuming the temp-variables are bound, will
  231.      return the old value of PLACE-FORM.
  232.  
  233. If PLACE-FORM doesn't have a setf-method, an error will be signaled.
  234.  
  235. Setf-methods can be defined using defsetf or define-setf-method.
  236.  
  237. For all the gory details, see CLtL."
  238.   (let ((place-form (%setfable-form-or-lose place-form)))
  239.     (if (symbolp place-form)
  240.     ;; 
  241.     (let ((store-var (gensym)))
  242.       (list nil nil (list store-var)
  243.         (list 'setq place-form store-var) place-form))
  244.     ;;
  245.     (let ((update-fun (%get-setf-simple-update-fun place-form))
  246.           (method (get (car place-form) 'setf-method)))
  247.       (cond (method
  248.          (apply method (cdr place-form)))
  249.         (update-fun
  250.          (let ((store-var (gensym))
  251.                (temps (%setf-gensyms (1- (length place-form)))))
  252.            (list temps
  253.              (cdr place-form)
  254.              (list store-var)
  255.              (cons update-fun (append temps (list store-var)))
  256.              (cons (car place-form) temps)))))))))
  257.  
  258. ;;; ----------------------------------------------------------------
  259.  
  260. (defmacro setf (place value &rest others)
  261.   "(setf PLACE VAL PLACE VAL ...) stores each VAL into the corresponding PLACE.
  262. Each PLACE is set before the next VAL is computed.
  263.  
  264. Each PLACE may be either a variable or a function call form that has an
  265. associated setf-method.  Care is taken not to evaluate the sub-forms of any
  266. PLACE more than once (note that only the sub-forms of each place, not the
  267. places themselves, are evaluated).
  268.  
  269. See defsetf and define-setf-method for an explanation of how to add a
  270. setf-method for a form that doesn't already have one.
  271.  
  272. Examples:
  273.    (setf (car a) b)    ; The same as (setcar a b)
  274.    (setf (get a b) c)    ; The same as (put a b c)"
  275.   (cond (others
  276.      (` (progn (setf (, place) (, value))
  277.            (setf (,@ others)))))
  278.     (t
  279.      (setf-update-form (nil place) value))))
  280.                
  281. (defmacro psetf (&rest places-and-values)
  282.   "(psetf PLACE VAL PLACE VAL ...) stores each VAL in parallel into the
  283. corresponding PLACE; that is, all arguments (including the arguments to
  284. each PLACE) are evaluated before any of the stores are done; all evaluation is
  285. still done left-to-right.
  286.  
  287. Each PLACE may be either a variable or a function call form that has an
  288. associated setf-method.  Care is taken not to evaluate the sub-forms of any
  289. PLACE more than once (note that only the sub-forms of each place, not the
  290. places themselves, are evaluated).
  291.  
  292. See defsetf and define-setf-method for an explanation of how to add a
  293. setf-method for a form that doesn't already have one."
  294.   (%psetf-expand places-and-values))
  295.  
  296. (defmacro shiftf (&rest places)
  297.   "(shiftf PLACE1 ... PLACEN) stores the value of each PLACE<X+1> into PLACEX,
  298. and returns the value of PLACE1.  The stores are done in `parallel'--
  299. all arguments are evaluated before any stores are done; evaluation is
  300. still done left-to-right.
  301.  
  302. Each PLACE may be either a variable or a function call form that has an
  303. associated setf-method.  Care is taken not to evaluate the sub-forms of any
  304. PLACE more than once.
  305.  
  306. See defsetf and define-setf-method for an explanation of how to add a
  307. setf-method for a form that doesn't already have one.
  308.  
  309. Examples:
  310.   ;; (car x) <- z, a <- the old value of (car x), return the old-value of a.
  311.   (shiftf a (car x) z)
  312.   ;;
  313.   ;; Set the position of the marker X to nil, and return the old value.
  314.   (shiftf (marker-position x) nil)"
  315.   (%shiftf-expand places nil))
  316.  
  317. (defmacro rotatef (&rest places)
  318.   "(rotatef PLACE1 ... PLACEN) stores the value of each PLACE<X+1> into PLACEX,
  319. and stores the value of PLACE1 into PLACEN.  The return-value is NIL.
  320. The stores are done in `parallel'-- all arguments are evaluated before any
  321. stores are done; evaluation is still done left-to-right.
  322.  
  323. Each PLACE may be either a variable or a function call form that has an
  324. associated setf-method.  Care is taken not to evaluate the sub-forms of any
  325. PLACE more than once.
  326.  
  327. See defsetf and define-setf-method for an explanation of how to add a
  328. setf-method for a form that doesn't already have one.
  329.  
  330. Examples:
  331.   ;; Swap the car and cdr of x
  332.   (rotatef (car x) (cdr x))"
  333.   (%shiftf-expand places t))
  334.  
  335. (defun %psetf-expand (p-and-v &optional bindings stores)
  336.   (if (null p-and-v)
  337.       (cons 'maybe-let* (cons (nreverse bindings) (nreverse stores)))
  338.       (let ((place (nth 0 p-and-v))
  339.         (value (nth 1 p-and-v)))
  340.     (with-setf-method (temps val-forms store-vars store-form access-form)
  341.         place
  342.       (%psetf-expand (nthcdr 2 p-and-v)
  343.              (cons (list (car store-vars) value)
  344.                    (nconc (%setf-zip temps val-forms)
  345.                       bindings))
  346.              (cons store-form stores))))))
  347.  
  348. (defun %shiftf-expand (places wrap-p)
  349.   (let ((first-var (gensym)))
  350.     (%shiftf-expand-1 places first-var first-var nil nil wrap-p)))
  351.  
  352. (defun %shiftf-expand-1 (places prev-store-var first-var bindings stores wrap-p)
  353.   (if (if wrap-p
  354.       (null places)
  355.       (null (cdr places)))        ; save the last value
  356.       (` (maybe-let* ((,@ (nreverse bindings))
  357.               ((, prev-store-var)
  358.                (, (if wrap-p first-var (car places)))))
  359.        (,@ (if wrap-p
  360.            (nreverse (cons nil stores))
  361.          (` ((prog1 (, first-var) (,@ (nreverse stores)))))))))
  362.       (with-setf-method (temps val-forms store-vars store-form access-form)
  363.       (car places)
  364.     (%shiftf-expand-1 (cdr places)
  365.               (car store-vars)
  366.               first-var
  367.               (cons (list prev-store-var access-form)
  368.                 (nconc (%setf-zip temps val-forms) bindings))
  369.               (cons store-form stores)
  370.               wrap-p))))
  371.  
  372. ;;; ----------------------------------------------------------------
  373.  
  374. (defmacro define-setf-method (access-fun args &rest body)
  375.   "(define-setf-method ACCESS-FUN ARGLIST BODY...) defines a `setf method'
  376. for ACCESS-FUN.  The BODY forms are evaluated by setf with the ARGS bound to
  377. the forms that are arguments to ACCESS-FUN in a setf place, and should return
  378. the setf method.
  379.  
  380. For an explanation of what a setf-method contains, see get-setf-method.
  381.  
  382. It often suffices to use the simpler defsetf instead of define-setf-method.
  383.  
  384. For further details, see CLtL."
  385.   (` (eval-and-compile
  386.        (put '(, access-fun) 'setf-update-fun nil)
  387.        (put '(, access-fun)
  388.         'setf-method
  389.         (function (lambda (, args) (,@ body))))
  390.        '(, access-fun))))
  391.  
  392. (defmacro defsetf (access-fun &rest other-args)
  393.   "Define a procedure for using setf with the function ACCESS-FUN.
  394.  
  395. Defsetf has two possible syntaxes:
  396.  1. (defsetf ACCESS-FUN UPDATE-FUN) -- Means that UPDATE-FUN will store into
  397.       the location accessed by ACCESS-FUN, and has the same arguments plus an
  398.       additional argument for the new value (neither ACCESS-FUN or UPDATE-FUN
  399.       is evaluted).
  400.  2. (defsetf ACCESS-FUN ARGLIST (NEWVAL) BODY ...) -- This is sort of like
  401.       defmacro (but including the extra (NEWVAL)).  When SETF needs to store
  402.       into a location accessed by ACCESS-FUN, it will evaluate the BODY forms,
  403.       which should return a form that does the update.  During the evaluation
  404.       of the BODY forms, the variables in ARGLIST will be bound to forms which
  405.       have the values of the corresponding arguments to ACCESS-FUN (but not
  406.       necessarily the original forms; note that unlike with defmacro, you
  407.       don't have to worry about protecting against multiple evaluation or
  408.       evaluation order-- this is all taken care for you), and NEWVAL will be
  409.       bound to some for which evaluates to the new value.
  410.  
  411. Examples:
  412.  (defsetf aref aset)            ; simple form
  413.  (defsetf nth (index list) (val)    ; complex form
  414.     (` (setf (car (nthcdr (, index) (, list))) (, val))))
  415.  
  416. Even more complex setf behavior can be defined using define-setf-method.
  417.  
  418. For more details, see CLtL."
  419.   (if (not (listp (car other-args)))
  420.       ;; simple defsetf
  421.       (` (eval-and-compile
  422.        (put '(, access-fun) 'setf-method nil)
  423.        (put '(, access-fun) 'setf-update-fun '(, (car other-args)))
  424.        '(, access-fun)))
  425.       ;; complex defsetf
  426.       (let* ((args (car other-args))
  427.          (store-var (car (car (cdr other-args))))
  428.          (body (cdr (cdr other-args))))
  429.     (if (cdr (car (cdr other-args)))
  430.         (error "DEFSETF can only handle one store-variable"))
  431.     (` (eval-and-compile
  432.          (put '(, access-fun) 'setf-update-fun nil)
  433.          (put '(, access-fun)
  434.           'setf-method
  435.           (function
  436.            (lambda (&rest place-args)
  437.              (let ((temps (%setf-gensyms (length place-args)))
  438.                (store-var (gensym)))
  439.                (list temps
  440.                  place-args
  441.                  (list store-var)
  442.                  (let (((, store-var) store-var))
  443.                    (apply (function
  444.                        (lambda (, args)
  445.                      (,@ body)))
  446.                       temps))
  447.                  (cons '(, access-fun) temps))))))
  448.          '(, access-fun))))))
  449.  
  450. ;;; This isn't as useful as it is in common lisp, since elisp doesn't have
  451. ;;; default values for default arguments (so incf can't use it, e.g.)
  452. (defmacro define-modify-macro (name args fun)
  453.   (let ((place-var (gensym)))
  454.     (` (defmacro (, name) (, (cons place-var args))
  455.      (setf-update-form (old-value (, place-var))
  456.        (` ((, '(, fun)) (, old-value) (, (,@ args)))))))))
  457.  
  458. (defmacro defsetf-and-return (access-fun update-fun)
  459.   "Like the simple form of defsetf, but adds noise to return the new value.
  460. Use this for functions who's update function takes all the arguments in the
  461. proper order but don't return the right value.  See defsetf for more details."
  462.   (` (defsetf (, access-fun) (&rest args) (value)
  463.        (` (progn ((, '(, update-fun)) (,@ args) (, value))
  464.          (, value))))))
  465.  
  466. ;;; ----------------------------------------------------------------
  467. ;;; some basic defsets
  468.  
  469. (defsetf aref aset)
  470. (defsetf get put)
  471. (defsetf car setcar)
  472. (defsetf cdr setcdr)
  473. (defsetf symbol-value set)
  474. (defsetf symbol-function fset)
  475. (defsetf symbol-plist setplist)
  476.  
  477. (defsetf nth (index list) (val)
  478.   (` (setf (car (nthcdr (, index) (, list))) (, val))))
  479. (defsetf nthcdr (index list) (val)
  480.   (` (setf (cdr (nthcdr (1- (, index)) (, list))) (, val))))
  481.  
  482. (defsetf elt (sequence index) (val)
  483.   (` (if (arrayp (, sequence))
  484.      (setf (aref (, sequence) (, index)) (, val))
  485.      (setf (nth (, index) (, sequence)) (, val)))))
  486.  
  487. ;;; ----------------------------------------------------------------
  488. ;;; Handy macros.  The tests for common cases aren't really necessary, they
  489. ;;; just avoid some consing.
  490.  
  491. (defmacro push (value place)
  492.   "Cons VALUE onto the front of the list in PLACE, and replace PLACE with the result.
  493.  
  494. PLACE may be either a variable or a function call form that has an associated
  495. setf-method.  Care is taken not to evaluate the sub-forms of PLACE more than
  496. once.
  497.  
  498. See defsetf and define-setf-method for an explanation of how to add a
  499. setf-method for a form that doesn't already have one."
  500.   (if (symbolp place)
  501.       ;; common case
  502.       (` (setq (, place) (cons (, value) (, place))))
  503.       ;; general case
  504.       (let ((val-var (gensym)))
  505.     (` (maybe-let (((, val-var) (, value)))
  506.          ;; We bind the value first to preserve l-to-r arument evaluation.
  507.          ;; [This will be removed if possible by the let-optimizer]
  508.          (, (setf-update-form (old place)
  509.           (` (cons (, val-var) (, old))))))))))
  510.  
  511. (defmacro pop (place)
  512.   "Replace PLACE with its cdr, and return its car.
  513.  
  514. PLACE may be either a variable or a function call form that has an associated
  515. setf-method.  Care is taken not to evaluate the sub-forms of PLACE more than
  516. once.
  517.  
  518. See defsetf and define-setf-method for an explanation of how to add a
  519. setf-method for a form that doesn't already have one."
  520.   (setf-update-form (old place (` (car (, old))))
  521.     (` (cdr (, old)))))
  522.     
  523. (defmacro incf (place &optional amount)
  524.   "Increment PLACE by AMOUNT (default 1).
  525.  
  526. PLACE may be either a variable or a function call form that has an associated
  527. setf-method.  Care is taken not to evaluate the sub-forms of PLACE more than
  528. once.
  529.  
  530. See defsetf and define-setf-method for an explanation of how to add a
  531. setf-method for a form that doesn't already have one."
  532.   (if (symbolp place)
  533.       ;; common case
  534.       (` (setq (, place) (+ (, place) (, (or amount 1)))))
  535.       ;; general case
  536.       (setf-update-form (old place)
  537.     (` (+ (, old) (, (or amount 1)))))))
  538.  
  539. (defmacro decf (place &optional amount)
  540.   "Decrement PLACE by AMOUNT (default 1).
  541.  
  542. PLACE may be either a variable or a function call form that has an associated
  543. setf-method.  Care is taken not to evaluate the sub-forms of PLACE more than
  544. once.
  545.  
  546. See defsetf and define-setf-method for an explanation of how to add a
  547. setf-method for a form that doesn't already have one."
  548.   (if (symbolp place)
  549.       ;; common case
  550.       (` (setq (, place) (- (, place) (, (or amount 1)))))
  551.       ;; general case
  552.       (setf-update-form (old place)
  553.     (` (- (, old) (, (or amount 1)))))))
  554.  
  555. (defmacro swapf (place1 place2)
  556.   "Exchange the values of PLACE1 and PLACE2.
  557.  
  558. PLACE1 and PLACE2 may be either variables or function call forms that have
  559. associated setf-methods.  Care is taken not to evaluate the sub-forms of
  560. either PLACE more than once.
  561.  
  562. The macro rotatef is exactly the same as swapf, but takes an arbitrary number
  563. of arguments.
  564.  
  565. See defsetf and define-setf-method for an explanation of how to add a
  566. setf-method for a form that doesn't already have one.
  567.  
  568. Examples:
  569.   ;; Swap the car and cdr of x
  570.   (swapf (car x) (cdr x))"
  571.   (%shiftf-expand (list place1 place2) t))
  572.  
  573. ;;; ----------------------------------------------------------------
  574. ;;; Emacs specific defsetfs.
  575. ;;; Note that we don't have to autoload these, since in order to use them, 
  576. ;;;   some other setf form must be called (which itself will be autoloaded).
  577. ;;;
  578.  
  579. ;; random stuff
  580. (defsetf default-value set-default)
  581. (defsetf marker-position set-marker)
  582. (defsetf get-register set-register)
  583. (defsetf file-modes set-file-modes)
  584. (defsetf-and-return match-data store-match-data)
  585.  
  586. ;; buffer stuff
  587. (defsetf current-buffer set-buffer)
  588. (defsetf buffer-name (buffer) (value)
  589.   (` (save-excursion
  590.        (setf (current-buffer) (, buffer))
  591.        (rename-buffer (, value))
  592.        (, value))))
  593. (defsetf buffer-modified-p set-buffer-modified-p)
  594. (defsetf mark set-mark)
  595. (defsetf point goto-char)
  596. (defsetf syntax-table set-syntax-table)
  597. (defsetf-and-return current-local-map use-local-map)
  598. (defsetf-and-return current-global-map use-global-map)
  599.  
  600. ;; window stuff
  601. (defsetf window-buffer set-window-buffer)
  602. (defsetf window-dot set-window-dot)
  603. (defsetf window-hscroll set-window-hscroll)
  604. (defsetf window-point set-window-point)
  605. (defsetf window-start set-window-start)
  606.  
  607. ;; screen stuff
  608. (defsetf-and-return current-window-configuration
  609.   set-window-configuration)
  610. (defsetf screen-height set-screen-height)
  611. (defsetf screen-width set-screen-width)
  612.  
  613. ;; process stuff
  614. (defsetf process-buffer set-process-buffer)
  615. (defsetf process-filter set-process-filter)
  616. (defsetf process-sentinel set-process-sentinel)
  617.