macros.lisp

   1 ;;; Copyright 2009-2011 Christoph Senjak
   2
   3 (in-package :uxul-world)
   4
   5 (defvar *current-translation-x* 0)
   6 (defvar *current-translation-y* 0)
   7 (defmacro with-translation-* ((x y) &body body)
   8   `(let ((*current-translation-x* (+ ,x *current-translation-x*))
   9          (*current-translation-y* (+ ,y *current-translation-y*)))
  10      ,@body))
  11
  12 (defmacro with-translation ((translation) &body body)
  13   `(with-translation-* ((x ,translation) (y ,translation)) ,@body))
  14
  15 (defmacro with-negative-translation-* ((x y) &body body)
  16   `(with-translation-* ((- ,x) (- ,y)) ,@body))
  17
  18 (defmacro with-negative-translation ((translation) &body body)
  19   `(with-negative-translation-* ((x ,translation) (y ,translation)) ,@body))
  20
  21 (defmacro directly-with-accessors (accessors objname &body body)
  22                `(with-accessors (
  23                                  ,@(let ((args nil))
  24                                    (dolist (arg accessors args)
  25                                      (push (list arg arg) args))))
  26                     ,objname ,@body))
  27
  28 (defun class-all-readers (class)
  29           (nconc (loop for superclass in
  30                       (closer-mop:class-direct-superclasses class)
  31                        nconc (class-all-readers superclass))
  32                  (loop for direct-slot in
  33                       (closer-mop:class-direct-slots class)
  34                     append
  35                       (closer-mop:slot-definition-readers direct-slot))))
  36
  37 (defmacro directly-with-all-accessors (classname objname &body body)
  38   `(directly-with-accessors (,@(class-all-readers (find-class classname)))
  39       ,objname ,@body))
  40
  41 (defmacro defvars (&rest vars)
  42   `(progn
  43      ,@(let ((ret nil))
  44             (dolist (var vars ret)
  45               (push `(defvar ,var) ret)))))
  46
  47
  48 (defmacro let-accessor (((accessor object) value) &body body)
  49   "Temporarily set an Accessor to another value."
  50   (let ((symbol (gensym)))
  51     `(let ((,symbol (,accessor ,object)))
  52        (unwind-protect
  53             (progn (setf (,accessor ,object) ,value) ,@body)
  54          (setf (,accessor ,object) ,symbol)))))
  55
  56 (defmacro let-accessors ((&rest bindings) &body body)
  57   "Temporarily set Accessors to other values."
  58   (let ((cbind (car bindings)))
  59     (if cbind
  60         `(let-accessor
  61              ((,(first (first cbind)) ,(second (first cbind))) ,(second cbind))
  62            (let-accessors (,@(cdr bindings)) ,@body))
  63         `(progn ,@body))))