Browse files

Never let test / key be nil

re ADWolf:#1358
  • Loading branch information...
1 parent 2d30d66 commit 8a8259e5c93605e9c68cc697efee71d09d6fc873 @bobbysmith007 bobbysmith007 committed Nov 30, 2015
Showing with 23 additions and 20 deletions.
  1. +23 −20 access.lisp
43 access.lisp
@@ -91,12 +91,15 @@
(defvar *default-test* #'access:equalper)
(defvar *default-key* #'identity)
+(defun default-test () (or *default-test* #'access:equalper))
+(defun default-key () (or *default-key* #'identity))
(defgeneric plist-val (id list &key test key)
(:documentation "get a value out of a plist based on its key")
- (:method (id list &key (test *default-test*) (key *default-key*))
+ (:method (id list &key (test (default-test)) (key (default-key)))
(iter (for (k v) on list by #'cddr)
- (for found = (funcall (or test *default-test*)
- (funcall (or key *default-key*) k)
+ (for found = (funcall (or test (default-test))
+ (funcall (or key (default-key)) k)
(when found
(return-from plist-val (values v found))))))
@@ -105,31 +108,31 @@
"removes key & its value from plist returning
(values plist (list-of-values-removed))")
- (:method (id list &key (test *default-test*) (key *default-key*))
+ (:method (id list &key (test (default-test)) (key (default-key)))
(for (k v) on list by #'cddr)
- (cond ((funcall (or test *default-test*)
- (funcall (or key *default-key*) k)
+ (cond ((funcall (or test (default-test))
+ (funcall (or key (default-key)) k)
(collect v into removed))
(T (collect k into plist)
(collect v into plist)))
(finally (return (values plist removed))))))
-(defmacro rem-plist-val! (id place &key (test '*default-test*) (key '*default-key*))
+(defmacro rem-plist-val! (id place &key (test '(default-test)) (key '(default-key)))
`(setf ,place
(rem-plist-val ,id ,place :test ,test :key ,key)))
(defgeneric set-plist-val (new id list &key test key)
(:documentation "If a key exists in the plist, set its value, otherwise add
this key to the dictionary")
- (:method (new id list &key (test *default-test*) (key *default-key*))
+ (:method (new id list &key (test (default-test)) (key (default-key)))
(with collected)
(for (k v) on list by #'cddr)
(collect k into res)
- (if (funcall (or test *default-test*)
- (funcall (or key *default-key*) k)
+ (if (funcall (or test (default-test))
+ (funcall (or key (default-key)) k)
(progn (setf collected T)
(collect new into res))
@@ -140,7 +143,7 @@
(return res)))))
(defmacro set-plist-val! (new id place
- &key (test '*default-test*) (key '*default-key*))
+ &key (test '(default-test)) (key '(default-key)))
`(setf ,place
(set-plist-val ,new ,id ,place :test ,test :key ,key)))
@@ -251,10 +254,10 @@
(access:class-slots o)))
-(defun class-slot-by-name (o k &key (test *default-test*) )
+(defun class-slot-by-name (o k &key (test (default-test)) )
(iter (for s in (access:class-slots o))
(for name = (ensure-slot-name s))
- (when (funcall (or test *default-test*)
+ (when (funcall (or test (default-test))
k name)
(return (values s name)))))
@@ -392,14 +395,14 @@
(defgeneric do-access (o k &key test key type skip-call?)
- (:method ((o list) k &key (test *default-test*) (key *default-key*)
+ (:method ((o list) k &key (test (default-test)) (key (default-key))
type skip-call?)
(declare (ignore skip-call?))
(if (or (eql type :alist)
(and (null type) (consp (first o))))
- (let ((assoc (assoc k o :test (or test *default-test*)
- :key (or key *default-key*))))
+ (let ((assoc (assoc k o :test (or test (default-test))
+ :key (or key (default-key)))))
(values (cdr assoc) (and assoc t)))
(plist-val k o :test test :key key)))
@@ -417,7 +420,7 @@
(awhen (ignore-errors (string k))
(gethash it o)))))
- (:method (o k &key (test *default-test*) (key *default-key*)
+ (:method (o k &key (test (default-test)) (key (default-key))
type skip-call?)
;; not specializing on standard-object here
;; allows this same code path to work with conditions (in sbcl)
@@ -431,11 +434,11 @@
;; lets recheck for an accessor in the correct package
(access o actual-slot-name
- :test (or test *default-test*)
- :key (or key *default-key*)
+ :test (or test (default-test))
+ :key (or key (default-key))
:type type :skip-call? skip-call?))))))
-(defun access (o k &key type (test *default-test*) (key *default-key*)
+(defun access (o k &key type (test (default-test)) (key (default-key))
"Access plists, alists, arrays, hashtables and clos objects
all through the same interface

0 comments on commit 8a8259e

Please sign in to comment.