home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / setf / plist.el < prev    next >
Encoding:
Text File  |  1992-04-22  |  4.6 KB  |  120 lines
  1. ;;; $Header: /home/user3/miles/src/elisp/RCS/plist.el,v 1.7 1992/04/21 17:32:15 miles Exp $
  2. ;;; ----------------------------------------------------------------
  3. ;;; plist.el -- Anonymous property lists.
  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. ;;; This file implements "anonymous" property-list functions, which are just
  22. ;;; property lists not bound to any symbol.
  23. ;;;
  24. ;;; In general, where the property list is stored in a place P (which can be
  25. ;;; a variable or any other form that can be set with setf), you look for
  26. ;;; properties using (getf P NAME), and change them using (setf (getf P NAME)
  27. ;;; VALUE).  So (getf (symbol-plist SYMBOL-NAME) NAME) is just like (get
  28. ;;; SYMBOL-NAME NAME).
  29. ;;;
  30. ;;; Getf also has the notion of a default value, which is what it returns
  31. ;;; when there isn't any property of the given name (as distuinguished from a
  32. ;;; property with a NIL value).
  33. ;;;
  34. ;;; So to increment the property 'zot in a property list stored in the car of
  35. ;;; the variable boing by 47, you do:
  36. ;;;   (incf (getf (car boing) 'zot 0) 47)
  37. ;;; Note the use of the default value zero to avoid an error if the property
  38. ;;; doesn't exist yet.
  39. ;;;
  40.  
  41. (provide 'plist)
  42.  
  43. (require 'setf)
  44. (require 'gensym)
  45.  
  46. (defun getf (plist propname &optional default)
  47.   "Return the value from the property list PLIST of the property PROPNAME.
  48. If there is no such property, return DEFAULT instead (which is optional and
  49. defaults to NIL).
  50.  
  51. May be used as a place with setf to change a property."
  52.   (while (and plist (not (eq (car plist) propname)))
  53.     (setf plist (cdr (cdr plist))))
  54.   (if plist
  55.       (car (cdr plist))
  56.       default))
  57.  
  58. (defun %putf (plist propname val)
  59.   "Don't use this, use (setf (getf PLIST PROPNAME) VALUE) instead."
  60.   (let ((tail plist))
  61.     (while (and tail (not (eq (car tail) propname)))
  62.       (setf tail (cdr (cdr tail))))
  63.     (cond (tail
  64.        (setf (car (cdr tail)) val)
  65.        plist)
  66.       (t
  67.        (cons propname (cons val plist))))))
  68.  
  69. (defun %plist-tail (plist propname)
  70.   (while (and plist (not (eq (car plist) propname)))
  71.     (setf plist (cdr (cdr plist))))
  72.   plist)
  73.  
  74. (define-setf-method getf (place propname &optional default)
  75.   (with-setf-method (temps values stores store-form access-form)
  76.       place
  77.     (let ((val-var (gensym))
  78.       (propname-var (gensym))
  79.       (def-var (if default (gensym))))
  80.       (list (append temps (list propname-var) (and default (list def-var)))
  81.         (append values (list propname) (and default (list default)))
  82.         (list val-var)
  83.         (` (maybe-let (((, (car stores))
  84.                 (%putf (, access-form)
  85.                    (, propname-var)
  86.                    (, val-var))))
  87.          (, store-form)
  88.          (, val-var)))
  89.         (` (getf (, access-form) (, propname-var)
  90.              (,@ (and default (list def-var)))))))))
  91.  
  92. (defmacro remf (place propname)
  93.   "Remove from the anonymous property-list stored in PLACE the property PROPNAME.
  94. Returns T if something was removed, NIL if nothing was done.
  95.  
  96. PLACE may be either a variable or a function call form that has an associated
  97. setf-method.  Care is taken not to evaluate the sub-forms of PLACE more than
  98. once.
  99.  
  100. See defsetf and define-setf-method for an explanation of how to add a
  101. setf-method for a form that doesn't already have one."
  102.   (with-setf-method (temps vals store-vars store-form access-form)
  103.     place
  104.     (let ((prop-var (gensym))
  105.       (head-var (gensym))
  106.       (tail-var (gensym))
  107.       (next-tail-var (gensym)))
  108.       (` (maybe-let ((,@ (%setf-zip temps vals))
  109.              ((, prop-var) (, propname)))
  110.        (maybe-let* (((, head-var) (, access-form))
  111.             ((, tail-var) (%plist-tail (, head-var) (, prop-var))))
  112.          (and (, tail-var)
  113.           (let (((, next-tail-var) (nthcdr 2 (, tail-var))))
  114.             (if (eq (, head-var) (, tail-var))
  115.             (maybe-let (((, (car store-vars)) (, next-tail-var)))
  116.                (, store-form))
  117.             (psetf (car (, tail-var)) (car (, next-tail-var))
  118.                    (cdr (, tail-var)) (cdr (, next-tail-var))))
  119.             t))))))))
  120.