trial/resource.lisp at master · pull-request-perhaps/trial · GitHub

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
#|
 This file is a part of trial
 (c) 2018 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.fraf.trial)

;; FIXME: configurable defaults

(defclass resource ()
  ())

(defgeneric allocate (resource))
(defgeneric deallocate (resource))
(defgeneric allocated-p (resource))

(defmethod load ((resource resource))
  (unless (allocated-p resource)
    (v:trace :trial.resource "Loading ~a" resource)
    (allocate resource)))

(defmethod allocate :around ((resource resource))
  (call-next-method)
  resource)

(defmethod deallocate :around ((resource resource))
  (call-next-method)
  resource)

(defmethod allocate :after ((resource resource))
  (setf (gethash resource (resources *context*)) resource))

(defmethod deallocate :after ((resource resource))
  (remhash resource (resources *context*)))

(defun check-allocated (resource)
  (unless (allocated-p resource)
    (error "~s is not yet allocated." resource)))

(defclass foreign-resource (resource)
  ((data-pointer :initform NIL :initarg :data-pointer :accessor data-pointer)))

(defgeneric destructor (foreign-resource))

(defmethod destructor ((resource foreign-resource))
  (lambda ()))

(defmethod allocated-p ((resource foreign-resource))
  (data-pointer resource))

(defmethod allocate :after ((resource foreign-resource))
  (tg:finalize resource (destructor resource)))

(defmethod deallocate ((resource foreign-resource))
  (funcall (destructor resource)))

(defmethod deallocate :after ((resource foreign-resource))
  (tg:cancel-finalization resource)
  (setf (data-pointer resource) NIL))

(defclass gl-resource (foreign-resource)
  ((data-pointer :accessor gl-name)))