/[gtk-cffi]/gtk-cffi/utils/utils.lisp
ViewVC logotype

Contents of /gtk-cffi/utils/utils.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sun Aug 19 16:22:30 2012 UTC (20 months ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +5 -0 lines
Fixed GDK for new CFFI version
1 (in-package :gtk-cffi-utils)
2
3 (defmacro debug-out (&body body)
4 ; (declare (ignore body))
5 `(format t ,@body)
6 )
7
8 (defmacro memo (place &body body)
9 `(or ,place
10 (setf ,place ,@body)))
11
12 (defun find-key (key seq)
13 (when seq
14 (if (eq key (car seq))
15 (list (first seq) (second seq))
16 (find-key key (cddr seq)))))
17
18 (defmacro with-hash (hash key &body body)
19 "If found KEY in HASH, return corresponding value,
20 else use BODY to calculate the value and save to HASH.
21 NIL values not saved"
22 (let ((try (gensym)))
23 `(or (gethash ,key ,hash)
24 (let ((,try (progn ,@body)))
25 (when ,try
26 (setf (gethash ,key ,hash) ,try))))))
27
28 (defmacro bitmask (&rest flags)
29 "Returns list from lisp values as keywords:
30 Example: (bitmask after swapped)
31 -> nil, when after=nil and swapped=nil
32 -> (:after), when after=t and swapped=nil
33 -> (:swapped), when after=nil and swapped=t
34 -> (:after :swapped), when both are t"
35 `(flatten
36 (list ,@(iter
37 (for flag in flags)
38 (collect `(when ,flag
39 ,(make-keyword flag)))))))
40
41 (defmacro template (vars args &body body)
42 "Universal template macro. For every ARG in ARGS binded to VARS generates
43 body. ARGS is list. If VARS also list, then every element in ARGS is
44 a list of the same length.
45 BODY of template should be as of DEFMACRO.
46 It should return list (resulting program chunk)."
47 (with-gensyms (%do %vars)
48 (cond
49 ((null vars)
50 `(macrolet ((,%do () ,@body))
51 (,%do)))
52 ((consp vars)
53 `(template ,%vars ,args
54 (destructuring-bind ,vars ,%vars
55 ,@body)))
56 (t `(macrolet ((,%do ()
57 `(progn
58 ,@(mapcar (lambda (,vars) ,@body) ',args))))
59 (,%do))))))
60

  ViewVC Help
Powered by ViewVC 1.1.5