My favorites | Sign in
Project Home Downloads Wiki Issues Source
Checkout   Browse   Changes  
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

(in-package #:sdl)

(defgeneric fp (foreign-object)
(:documentation "Returns the foreign pointer in FOREIGN-OBJECT"))

(defgeneric this-fp (foreign-object)
(:documentation "Returns the reference to the foreign object for this FOREIGN-OBJECT.
The difference between FP and THIS-FP, is that FP can be overriden, for example
to refer to the TARGET-NODE of a META-NODE."))

(defgeneric free (foreign-object)
(:documentation "The general explicit cleanup method for the
FOREIGN-OBJECT wrapper class. Objects that subclass FOREIGN-OBJECT should
specify an :AFTER method on FREE to clean up any additional fields, if necessary."))

(defgeneric (setf gc-p) (value foreign-object)
(:documentation "Turns on garbage collection for the FOREIGN-OBJECT when T, or turns off
garbage collection when NIL."))

(defclass foreign-object ()
((foreign-pointer-to-object
:reader fp
:initform nil
:initarg :fp)
(garbage-collect
:reader gc-p
:initform t
:initarg :gc)
(free-function
:initform (error "FREE-FUNCTION must not be NIL.")
:initarg :free)))

(defmethod initialize-instance :around ((self foreign-object)
&key)
(call-next-method)
(when (gc-p self)
(let ((foreign-pointer (this-fp self))
(foreign-free (slot-value self 'free-function)))
(tg:finalize self (lambda ()
(funcall foreign-free foreign-pointer))))))

(defmethod free ((self foreign-object))
;; This is the general explicit cleanup method for all OpenRM objects.
;; Objects that subclass FOREIGN-OBJECT should specify an :AFTER
;; method on FREE to clean up any additional fields, if necessary.
(funcall (slot-value self 'free-function) (this-fp self))
(tg:cancel-finalization self)
(setf (slot-value self 'foreign-pointer-to-object) nil
(slot-value self 'garbage-collect) nil))

(defmethod (setf gc-p) (value (self foreign-object))
(if value
(let ((foreign-pointer (this-fp self))
(foreign-free (slot-value self 'free-function)))
(setf (slot-value self 'garbage-collect) t)
(tg:cancel-finalization self)
(tg:finalize self (lambda ()
(funcall foreign-free foreign-pointer))))
(progn
(setf (slot-value self 'garbage-collect) nil)
(tg:cancel-finalization self))))

(defmethod this-fp ((self foreign-object))
(slot-value self 'foreign-pointer-to-object))

(defun simple-free (func-fp type)
(declare (ignorable type))
#'(lambda (obj-fp)
(when (sdl:is-valid-ptr obj-fp)
(funcall func-fp obj-fp))))

Change log

r1532 by elliottslaughter on Nov 27, 2013   Diff
Cosmetic whitespace fixes

  * All trailing whitespace removed.
  * Any DOS style newlines changed to
Unix.
  * All files end in a newline.

Patch by xolodho.
Go to: 
Project members, sign in to write a code review

Older revisions

r744 by hairytroll on Nov 12, 2008   Diff
Minor updates;
 - :UPDATE-P now :UPDATE
 - :CLIPPING-P now :CLIPPING

Documentation updates.
r736 by hairytroll on Oct 4, 2008   Diff
Forgot to add base.lisp
All revisions of this file

File info

Size: 2479 bytes, 71 lines
Powered by Google Project Hosting