[gtk-cffi-cvs] CVS gtk-cffi/cffi

[CVS User rklochkov]

Update of /project/gtk-cffi/cvsroot/gtk-cffi/cffi
In directory tiger.common-lisp.net:/tmp/cvs-serv18903/cffi

Added Files:
	struct.lisp 
Log Message:
Forgot one file



--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/08/26 17:39:35	NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/08/26 17:39:35	1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; array.lisp --- CFFI wrapper for arrays
;;;
;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
;;;

(in-package :cffi-object)

(defmacro defcstruct-accessors (class &rest slots)
  "CLASS maybe symbol = class-name = struct name,
or maybe cons (class-name . struct-name)"
  (let ((class-name (if (consp class) (car class) class))
        (struct-name (if (consp class) (cdr class) class)))
    `(progn
       ,@(iter
          (for x in slots)
          (collect 
           `(progn
              (defmethod ,x ((,class-name ,class-name))
                (foreign-slot-value (pointer ,class-name) ',struct-name ',x))
              (defmethod (setf ,x) (val (,class-name ,class-name))
                (setf (foreign-slot-value (pointer ,class-name) 
                                          ',struct-name ',x) val))))))))

(defmacro defcstruct* (class &body body)
  `(progn 
    (defcstruct ,class , at body)
    (defcstruct-accessors ,class
        ,@(iter
           (for x in body)
           (when (consp x) (collect (car x)))))))