summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorBT Templeton <bpt@hcoop.net>2011-07-10 19:17:08 -0400
committerBT Templeton <bpt@hcoop.net>2012-02-03 18:53:49 -0500
commit12ca82caa2e52cceeb2981399da9f661ca4e784e (patch)
tree495e16f9aa4a52058657ee93e90c1ab837504347 /module/language
parent0c5fe7d804e3735c592edd92722697751c40aedb (diff)
downloadguile-12ca82caa2e52cceeb2981399da9f661ca4e784e.tar.gz
elisp property lists
* module/language/elisp/boot.el (%plist-member, %plist-get, %plist-put) (plist-get, plist-put, plist-member, lax-plist-get, lax-plist-put) (symbol-plist, setplist, get, put): New functions. (plist-function): New variable.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/elisp/boot.el47
1 files changed, 47 insertions, 0 deletions
diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el
index 0bbf4efd2..bc9d6ad12 100644
--- a/module/language/elisp/boot.el
+++ b/module/language/elisp/boot.el
@@ -261,3 +261,50 @@
(defun mapcar (function sequence)
(funcall (@ (guile) map) function sequence))
+
+;;; Property lists
+
+(defun %plist-member (plist property test)
+ (catch 'loop
+ (while plist
+ (if (funcall test (car plist) property)
+ (throw 'loop (cdr plist))
+ (setq plist (cddr plist))))))
+
+(defun %plist-get (plist property test)
+ (car (%plist-member plist property test)))
+
+(defun %plist-put (plist property value test)
+ (lexical-let ((x (%plist-member plist property test)))
+ (if x
+ (progn (setcar x value) plist)
+ (cons property (cons value plist)))))
+
+(defun plist-get (plist property)
+ (%plist-get plist property #'eq))
+
+(defun plist-put (plist property value)
+ (%plist-put plist property value #'eq))
+
+(defun plist-member (plist property)
+ (%plist-member plist property #'eq))
+
+(defun lax-plist-get (plist property)
+ (%plist-get plist property #'equal))
+
+(defun lax-plist-put (plist property value)
+ (%plist-put plist property value #'equal))
+
+(defvar plist-function (funcall (@ (guile) make-object-property)))
+
+(defun symbol-plist (symbol)
+ (funcall plist-function symbol))
+
+(defun setplist (symbol plist)
+ (funcall (funcall (@ (guile) setter) plist-function) symbol plist))
+
+(defun get (symbol propname)
+ (plist-get (symbol-plist symbol) propname))
+
+(defun put (symbol propname value)
+ (setplist symbol (plist-put (symbol-plist symbol) propname value)))