Permalink
Browse files

UTILS: Adding macro COLLECT

Also scrapping old macro WITH-PUSH-ONTO
  • Loading branch information...
1 parent 57ddfb9 commit 9f6a26f6ae36fd50ff055697d0bd413f1bf2acdc @adlai committed Dec 20, 2009
Showing with 23 additions and 42 deletions.
  1. +9 −9 src/explain.lisp
  2. +14 −33 src/utils.lisp
View
18 src/explain.lisp
@@ -67,18 +67,18 @@
(defun partition-results (results-list)
(let ((num-checks (length results-list)))
- (with-push-onto (passed skipped failed unknown)
+ (collect (passed skipped failed unknown)
(dolist (result results-list)
(typecase result
- (test-passed (push-onto passed result))
- (test-skipped (push-onto skipped result))
- (test-failure (push-onto failed result))
- (otherwise (push-onto unknown result))))
+ (test-passed (passed result))
+ (test-skipped (skipped result))
+ (test-failure (failed result))
+ (otherwise (unknown result))))
(if (zerop num-checks)
(values 0 nil 0 0 nil 0 0 nil 0 0 nil 0 0)
(values
num-checks
- passed (length passed) (floor (* 100 (/ (length passed) num-checks)))
- skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks)))
- failed (length failed) (floor (* 100 (/ (length failed) num-checks)))
- unknown (length unknown) (floor (* 100 (/ (length failed) num-checks))))))))
+ (passed) (length (passed)) (floor (* 100 (/ (length (passed)) num-checks)))
+ (skipped) (length (skipped)) (floor (* 100 (/ (length (skipped)) num-checks)))
+ (failed) (length (failed)) (floor (* 100 (/ (length (failed)) num-checks)))
+ (unknown) (length (unknown)) (floor (* 100 (/ (length (failed)) num-checks))))))))
View
47 src/utils.lisp
@@ -12,43 +12,24 @@
`(let ((it ,test))
(if it ,true ,false)))
-(defun parallel-lookup (thing key-list value-list &key (test #'eql) (key #'identity))
- (map nil (lambda (k v)
- (when (funcall test thing (funcall key k))
- (return-from parallel-lookup v)))
- key-list value-list))
-
-(defmacro pushend (new-item list list-end &environment env)
- (multiple-value-bind (list.gvars list.vals list.gstorevars list.setter list.getter)
- (get-setf-expansion list env)
- (multiple-value-bind (tail.gvars tail.vals tail.gstorevars tail.setter tail.getter)
- (get-setf-expansion list-end env)
- (let ((gitem (gensym))
- (list.gstorevar (first list.gstorevars))
- (tail.gstorevar (first tail.gstorevars)))
- `(let (,@(mapcar #'list list.gvars list.vals)
- ,@(mapcar #'list tail.gvars tail.vals))
- (let ((,gitem (list ,new-item)))
- (if ,list.getter
- (let ((,tail.gstorevar ,gitem))
- (setf (cdr ,tail.getter) ,gitem)
- ,tail.setter)
- (let ((,list.gstorevar ,gitem)
- (,tail.gstorevar ,gitem))
- ,list.setter ,tail.setter))))))))
-
-(defmacro with-push-onto ((&rest places) &body body)
- (let ((end-names (mapcar (fun (gensym (symbol-name _))) places)))
- `(let (,@places ,@end-names)
- (macrolet ((push-onto (place thing)
- `(pushend ,thing ,place
- ,(parallel-lookup place ',places ',end-names))))
- ,@body))))
-
(defmacro with-gensyms ((&rest syms) &body body)
"This is a simple WITH-GENSYMS, similar to the one presented in PCL."
`(let ,(mapcar (fun `(,_ (gensym ,(string _)))) syms) ,@body))
+(defmacro collect (names &body body &aux macros binds)
+ (dolist (name names)
+ (with-gensyms (value tail)
+ (setf binds (list* value tail binds))
+ (push `(,name (&optional (form nil formp))
+ `(if ,formp
+ (let ((cons (list ,form)))
+ (cond ((null ,',tail)
+ (setf ,',tail cons ,',value cons))
+ (t (setf (cdr ,',tail) cons ,',tail cons))))
+ ,',value))
+ macros)))
+ `(let* ,(nreverse binds) (macrolet ,macros ,@body)))
+
;;; This is based on from Arnesi's src/list.lisp, and implements a naive ;;; list matching facility.
;;; Marco Baringer says in the original:
;;; ;;;; ** Simple list matching based on code from Paul Graham's On Lisp.

0 comments on commit 9f6a26f

Please sign in to comment.