/[cffi-objects]/setters.lisp
ViewVC logotype

Contents of /setters.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Thu Feb 9 15:53:55 2012 UTC (2 years, 2 months ago) by rklochkov
File size: 1828 byte(s)
Initial release
1 rklochkov 1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2     ;;;
3     ;;; object.lisp --- Auto setters for foreign slots
4     ;;;
5     ;;; Copyright (C) 2007, Roman Klochkov <monk@slavsoft.surgut.ru>
6     ;;;
7    
8     (in-package #:cffi-objects)
9    
10     (defmacro save-setter (class name)
11     "Use this to register setters for SETF-INIT and INIT-SLOTS macro"
12     `(eval-when (:compile-toplevel :load-toplevel :execute)
13     (pushnew ',name (get ',class 'slots))))
14    
15     (defmacro remove-setter (class name)
16     "Use this to unregister setters for SETF-INIT and INIT-SLOTS macro"
17     `(eval-when (:compile-toplevel :load-toplevel :execute)
18     (setf (get ',class 'slots)
19     (delete ',name (get ',class 'slots)))))
20    
21     (defmacro clear-setters (class)
22     `(eval-when (:compile-toplevel :load-toplevel :execute)
23     (setf (get ',class 'slots) nil)))
24    
25     (defmacro setf-init (object &rest fields)
26     "Should be used in constructors"
27     `(progn
28     ,@(mapcar (lambda (field-all)
29     (let ((field (if (consp field-all)
30     (first field-all) field-all))
31     (field-p (if (consp field-all)
32     (third field-all) field-all)))
33     `(when ,field-p
34     (setf (,field ,object) ,field))))
35     fields)))
36    
37     (defun name-p (name)
38     (intern (format nil "~a-P" name) (symbol-package name)))
39    
40     (defmacro init-slots (class &optional add-keys &body body)
41     "For SETF-INIT auto-constructor"
42     (let ((slots (mapcar (lambda (x) (list x nil (name-p x)))
43     (get class 'slots))))
44     `(defmethod shared-initialize :after ((,class ,class) slot-names
45     &key ,@slots ,@add-keys
46     &allow-other-keys)
47     (declare (ignore slot-names))
48     (setf-init ,class ,@slots)
49     ,@body)))

  ViewVC Help
Powered by ViewVC 1.1.5