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

Contents of /setters.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (show annotations)
Thu Aug 9 16:55:23 2012 UTC (20 months ago) by rklochkov
File size: 2265 byte(s)
Added function INITIALIZE
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 (unless (initialized ,object ,field)
35 (setf (,field ,object) ,field)
36 (initialize ,object ,field)))))
37 fields)))
38
39 (defun initialized (obj field)
40 (find field (slot-value obj 'initialized)))
41
42 (defun initialize (obj fields)
43 "Used when you need to mark, that FIELDS already initialized"
44 (etypecase fields
45 (list (dolist (field fields)
46 (initialize obj field)))
47 (symbol (push fields (slot-value obj 'initialized)))))
48
49 (defun name-p (name)
50 (intern (format nil "~a-P" name) (symbol-package name)))
51
52 (defmacro init-slots (class &optional add-keys &body body)
53 "For SETF-INIT auto-constructor"
54 (let ((slots (mapcar (lambda (x) (list x nil (name-p x)))
55 (get class 'slots))))
56 `(defmethod shared-initialize :after ((,class ,class) slot-names
57 &key ,@slots ,@add-keys
58 &allow-other-keys)
59 (declare (ignore slot-names))
60 (setf-init ,class ,@slots)
61 ,@body)))

  ViewVC Help
Powered by ViewVC 1.1.5