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

Contents of /setters.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 8 - (hide annotations)
Sun Aug 12 17:36:30 2012 UTC (20 months ago) by rklochkov
File size: 2266 byte(s)
Changed API for freeable to be consistent with CFFI: 
changed :FREE to :FREE-FROM-FOREIGN and :FREE-TO-FOREIGN as in :STRING

Synced with last version of CFFI


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 rklochkov 7 (unless (initialized ,object ,field)
35     (setf (,field ,object) ,field)
36 rklochkov 8 (initialize ,object ',field)))))
37 rklochkov 1 fields)))
38    
39 rklochkov 7 (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 rklochkov 1 (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