/
c-object.lisp
54 lines (44 loc) · 1.78 KB
/
c-object.lisp
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
#|
This file is a part of cl-steamworks
(c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.fraf.steamworks)
(defvar *c-object-table* (make-hash-table :test 'eql))
(defun pointer->object (pointer)
(let ((address (etypecase pointer
(cffi:foreign-pointer (cffi:pointer-address pointer))
(integer pointer))))
(gethash address *c-object-table*)))
(defun (setf pointer->object) (object pointer)
(let ((address (etypecase pointer
(cffi:foreign-pointer (cffi:pointer-address pointer))
(integer pointer))))
(if object
(setf (gethash address *c-object-table*) object)
(remhash address *c-object-table*))))
(defclass c-object ()
((handle :initarg :handle :initform NIL :accessor handle)))
(defclass c-managed-object (c-object)
())
(defmethod initialize-instance ((object c-managed-object) &key free-on-gc)
(call-next-method)
(unless (handle object)
(let ((handle (allocate-handle object)))
(when free-on-gc
(tg:finalize object (free-handle-function object handle)))
(setf (handle object) handle)
(setf (pointer->object handle) object))))
(defmethod initialize-instance :around ((object c-managed-object) &key handle)
(if handle
(call-next-method)
(with-cleanup-on-failure (free object)
(call-next-method))))
(defgeneric allocate-handle (c-managed-object))
(defgeneric free-handle-function (c-managed-object handle))
(defmethod free ((object c-managed-object))
(let ((handle (when (slot-boundp object 'handle) (handle object))))
(when handle
(tg:cancel-finalization object)
(setf (handle object) NIL)
(funcall (free-handle-function object handle)))))