Foreign object handle

borodust · Dec 9, 2016 · aa7346a · aa7346a
1 parent 28f0cb6
commit aa7346a
Show file tree

Hide file tree

Showing 18 changed files with 174 additions and 117 deletions.
diff --git a/audio/al.lisp b/audio/al.lisp
@@ -1,5 +1,4 @@
 (in-package :cl-bodge.audio)
 
 
-(defclass al-object (disposable thread-bound-object)
-  ((id :initarg :id :initform (error "id must be provided") :reader id-of)))
+(defclass al-object (foreign-object) ())
diff --git a/audio/buffer.lisp b/audio/buffer.lisp
@@ -1,15 +1,13 @@
 (in-package :cl-bodge.audio)
 
 
+(defhandle audio-buffer-handle
+    :initform (al:gen-buffer)
+    :closeform (al:delete-buffer *handle-value*))
 
 
 (defclass audio-buffer (al-object) ()
-  (:default-initargs :id (al:gen-buffer)))
-
-
-(define-destructor audio-buffer ((id id-of) (sys system-of))
-  (-> (sys :priority :low)
-    (al:delete-buffer id)))
+  (:default-initargs :handle (make-audio-buffer-handle)))
 
 
 (defmethod initialize-instance :after ((this audio-buffer)
@@ -20,7 +18,7 @@
                         (16 :int16)))
         (foreign-size (* (/ sample-depth 8) (length pcm-data))))
     (cffi:with-foreign-array (raw-data pcm-data (list :array foreign-type (length pcm-data)))
-      (al:buffer-data (id-of this) pcm-format raw-data foreign-size sampling-rate))))
+      (al:buffer-data (handle-value-of this) pcm-format raw-data foreign-size sampling-rate))))
 
 
 

diff --git a/audio/source.lisp b/audio/source.lisp
@@ -12,38 +12,38 @@
 (declaim (ftype (function (audio-buffer audio-source) *) attach-buffer)
          (inline attach-buffer))
 (defun attach-audio-buffer (buffer source)
-  (al:source (id-of source) :buffer (id-of buffer)))
+  (al:source (handle-value-of source) :buffer (handle-value-of buffer)))
 
 
 (declaim (ftype (function (audio-source) *) play-audio)
          (inline play-audio))
 (defun play-audio (source)
-  (al:source-play (id-of source)))
+  (al:source-play (handle-value-of source)))
 
 
 (declaim (ftype (function (audio-source) *) stop-audio)
          (inline stop-audio))
 (defun stop-audio (source)
-  (al:source-stop (id-of source)))
+  (al:source-stop (handle-value-of source)))
 
 
 (declaim (ftype (function (audio-source) *) pause-audio)
          (inline pause-audio))
 (defun pause-audio (source)
-  (al:source-pause (id-of source)))
+  (al:source-pause (handle-value-of source)))
 
 
 (defun audio-looped-p (source)
-  (al:get-source (id-of source) :looped))
+  (al:get-source (handle-value-of source) :looped))
 
 
 (defun (setf audio-looped-p) (value source)
-  (al:source (id-of source) :looping (if value :true :false)))
+  (al:source (handle-value-of source) :looping (if value :true :false)))
 
 
 (defun audio-gain (source)
-  (al:get-source (id-of source) :gain))
+  (al:get-source (handle-value-of source) :gain))
 
 
 (defun (setf audio-gain) (value source)
-  (al:source (id-of source) :gain value))
+  (al:source (handle-value-of source) :gain value))
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -110,6 +110,7 @@
                (:file "mesh")
                (:file "shading")
                (:file "textures")
+               (:file "framebuffer")
                (:file "system")))
 
 

diff --git a/engine/engine.lisp b/engine/engine.lisp
@@ -203,3 +203,47 @@
   (call-next-method)
   (with-slots (enabled-p) this
     (setf enabled-p nil)))
+
+
+;;;
+;;;
+;;;
+(defclass handle ()
+  ((value :initarg :value :initform (error ":value initarg missing") :reader value-of)))
+
+
+(defclass foreign-object (disposable system-object)
+  ((handle :initarg :handle :initform (error "foreign object :handle must be supplied")
+           :reader handle-of)))
+
+
+(definline handle-value-of (foreign-object)
+  (with-slots (handle) foreign-object
+    (value-of handle)))
+
+
+(defgeneric destroy-foreign-object (handle))
+
+
+(declaim (special *handle-value*))
+
+
+(defmacro defhandle (name &key (initform nil)
+                            (closeform (error ":closeform must be supplied")))
+  (with-gensyms (handle value)
+    `(progn
+       (defclass ,name (handle) ())
+
+       (defmethod destroy-foreign-object ((,handle ,name))
+         (let ((*handle-value* (value-of ,handle)))
+           ,closeform))
+
+       (definline ,(symbolicate 'make- name) (&optional ,value)
+         (make-instance ',name :value (or ,value ,initform
+                                          (error "value or :initform must be provided")))))))
+
+
+
+(define-destructor foreign-object ((handle handle-of) (sys system-of))
+  (-> (sys :priority :low :important t)
+    (destroy-foreign-object handle)))
diff --git a/engine/packages.lisp b/engine/packages.lisp
@@ -116,6 +116,12 @@
              system-of
              enableable
 
+             foreign-object
+             handle-value-of
+             destroy-foreign-object
+             defhandle
+             *handle-value*
+
              generic-system
              with-system-lock-held
              initialize-system

diff --git a/engine/thread-bound-system.lisp b/engine/thread-bound-system.lisp
@@ -73,9 +73,6 @@
 
 
 ;;
-(defclass thread-bound-object (system-object) ())
-
-
 (defmacro define-system-function (name system-class lambda-list &body body)
   (multiple-value-bind (forms decls doc) (parse-body body :documentation t)
     `(defun ,name ,lambda-list

diff --git a/graphics/buffers.lisp b/graphics/buffers.lisp
@@ -3,17 +3,17 @@
 
 (declaim (special *active-buffer*))
 
+
+(defhandle buffer-handle
+    :initform (gl:gen-buffer)
+    :closeform (gl:delete-buffers (list *handle-value*)))
+
 ;;
 ;;
 (defclass buffer (gl-object)
   ((target :initarg :target :initform (error "Buffer target should be provided")
            :reader target-of))
-  (:default-initargs :id (gl:gen-buffer)))
-
-
-(define-destructor buffer ((id id-of) (sys system-of))
-  (-> (sys :priority :low)
-    (gl:delete-buffers (list id))))
+  (:default-initargs :handle (make-buffer-handle)))
 
 
 (defgeneric attach-array-buffer (buffer target index))
@@ -23,11 +23,11 @@
   (once-only (buffer)
     `(unwind-protect
           (progn
-            (gl:bind-buffer (target-of ,buffer) (id-of ,buffer))
+            (gl:bind-buffer (target-of ,buffer) (handle-value-of ,buffer))
             (let ((*active-buffer* ,buffer))
               ,@body))
        (if-bound *active-buffer*
-                 (gl:bind-buffer (target-of *active-buffer*) (id-of *active-buffer*))
+                 (gl:bind-buffer (target-of *active-buffer*) (handle-value-of *active-buffer*))
                  (gl:bind-buffer (target-of ,buffer) 0)))))
 
 ;;

diff --git a/graphics/framebuffer.lisp b/graphics/framebuffer.lisp
@@ -0,0 +1,10 @@
+(in-package :cl-bodge.graphics)
+
+
+(defhandle framebuffer-handle
+    :initform (gl:gen-framebuffer)
+    :closeform (gl:delete-buffers (list *handle-value*)))
+
+
+(defclass framebuffer (gl-object) ()
+  (:default-initargs :handle (make-framebuffer-handle)))
diff --git a/graphics/gl.lisp b/graphics/gl.lisp
@@ -4,8 +4,8 @@
 (defgeneric render (renderable))
 
 
-(defclass gl-object (disposable thread-bound-object)
-  ((id :initarg :id :reader id-of)))
+(defclass gl-object (foreign-object) ())
+
 
 
 ;; up to 2 dimensions

diff --git a/graphics/shading.lisp b/graphics/shading.lisp
@@ -12,13 +12,12 @@
     (:tessellation-evaluation-shader :tess-evaluation-shader)))
 
 
-(defclass shader (gl-object)
-  ((type :initarg :type :reader shader-type-of)))
+(defhandle shader-handle
+    :closeform (gl:delete-shader *handle-value*))
 
 
-(define-destructor shader ((id id-of) (sys system-of))
-  (-> (sys :priority :low)
-    (gl:delete-shader id)))
+(defclass shader (gl-object)
+  ((type :initarg :type :reader shader-type-of)))
 
 
 (defun %compile-shader (type source name)
@@ -33,7 +32,9 @@
 
 
 (defmethod initialize-instance ((this shader) &key type source system (name ""))
-  (call-next-method this :id (%compile-shader type source name) :system system :type type))
+  (call-next-method this
+                    :handle (make-shader-handle (%compile-shader type source name))
+                    :system system :type type))
 
 
 (define-system-function compile-shader graphics-system (shader-source &key (system *system*))
@@ -50,35 +51,35 @@
 ;;;
 ;;;
 ;;;
-(defclass shading-program (gl-object) ()
-  (:default-initargs :id (gl:create-program)))
+(defhandle shading-progrm-handle
+    :initform (gl:create-program)
+    :closeform (gl:delete-program *handle-value*))
 
 
-(define-destructor shading-program ((id id-of) (sys system-of))
-  (-> (sys :priority :low)
-    (gl:delete-program id)))
+(defclass shading-program (gl-object) ()
+  (:default-initargs :handle (make-shading-progrm-handle)))
 
 
 (defun %make-program (this shader-sources precompiled-shaders)
-  (let* ((program (id-of this))
+  (let* ((program (handle-value-of this))
          (shaders (loop for src in shader-sources collect
                        (compile-shader src)))
          (all-shaders (append precompiled-shaders shaders)))
     (unwind-protect
          (loop for shader in all-shaders do
-              (gl:attach-shader program (id-of shader)))
+              (gl:attach-shader program (handle-value-of shader)))
       (gl:link-program program)
       (unless (gl:get-program program :link-status)
         (error "Program linking failed:~%~a" (gl:get-program-info-log program)))
       (loop for shader in all-shaders do
-           (gl:detach-shader program (id-of shader)))
+           (gl:detach-shader program (handle-value-of shader)))
       (loop for shader in shaders do
            (dispose shader)))))
 
 
 (defmethod initialize-instance :after ((this shading-program)
                                        &key shader-sources shaders separable-p)
-  (gl:program-parameteri (id-of this) :program-separable separable-p)
+  (gl:program-parameteri (handle-value-of this) :program-separable separable-p)
   (%make-program this shader-sources shaders))
 
 
@@ -106,7 +107,7 @@
 
 
 (defun use-shading-program (program)
-  (gl:use-program (id-of program)))
+  (gl:use-program (handle-value-of program)))
 
 
 (defmacro with-using-shading-program ((program &optional prev-program) &body body)
@@ -117,58 +118,59 @@
             ,@body)
        ,(if (null prev-program)
             `(if-bound *active-shading-program*
-                       (gl:use-program (id-of *active-shading-program*))
+                       (gl:use-program (handle-value-of *active-shading-program*))
                        (gl:use-program 0))
-            `(gl:use-program (id-of ,prev-program))))))
+            `(gl:use-program (handle-value-of ,prev-program))))))
 
 
 (defun valid-shading-program-p (program)
-  (and (not (null program)) (gl:is-program (id-of program))))
+  (and (not (null program)) (gl:is-program (handle-value-of program))))
 
 
 #|
 ;; fixme: find out appropriate return type
 (defun program-uniform-variable (program variable-name)
-  (when-let ((variable-idx (gl:get-uniform-location (id-of program) variable-name)))
-    (gl:get-active-uniform (id-of program) variable-idx)))
+  (when-let ((variable-idx (gl:get-uniform-location (handle-value-of program) variable-name)))
+    (gl:get-active-uniform (handle-value-of program) variable-idx)))
 |#
 
 (defun (setf program-uniform-variable) (value program variable-name)
-  (when-let ((variable-idx (gl:get-uniform-location (id-of program) variable-name)))
+  (when-let ((variable-idx (gl:get-uniform-location (handle-value-of program) variable-name)))
     (etypecase value
-      (integer (gl:program-uniformi (id-of program) variable-idx value))
-      (single-float (gl:program-uniformf (id-of program) variable-idx value))
-      (vec (gl:program-uniformfv (id-of program) variable-idx (vec->array value)))
-      (square-mat (gl:program-uniform-matrix (id-of program) variable-idx
+      (integer (gl:program-uniformi (handle-value-of program) variable-idx value))
+      (single-float (gl:program-uniformf (handle-value-of program) variable-idx value))
+      (vec (gl:program-uniformfv (handle-value-of program) variable-idx (vec->array value)))
+      (square-mat (gl:program-uniform-matrix (handle-value-of program) variable-idx
                                              (square-matrix-size value)
                                              (vector (mat->array value)) nil)))))
 
 
 ;;;
 ;;; Shading program pipeline
 ;;;
-(defclass shading-pipeline (gl-object) ()
-  (:default-initargs :id (gl:gen-program-pipeline)))
+(defhandle shading-pipeline-handle
+    :initform (gl:gen-program-pipeline)
+    :closeform (gl:delete-program-pipelines (list *handle-value*)))
 
 
-(define-destructor shading-pipeline ((id id-of) (sys system-of))
-  (-> (sys :priority :low)
-    (gl:delete-program-pipelines (list id))))
+(defclass shading-pipeline (gl-object) ()
+  (:default-initargs :handle (make-shading-pipeline-handle)))
 
 
 (define-system-function make-shading-pipeline graphics-system (&key (system *system*))
   (make-instance 'shading-pipeline :system system))
 
+
 (defmacro with-bound-shading-pipeline ((pipeline) &body body)
   (once-only (pipeline)
     `(unwind-protect
           (let ((*active-shading-pipeline* ,pipeline))
-            (gl:bind-program-pipeline (id-of ,pipeline))
+            (gl:bind-program-pipeline (handle-value-of ,pipeline))
             ,@body)
        (if-bound *active-shading-pipeline*
-           (gl:bind-program-pipeline (id-of *active-shading-pipeline*))
+           (gl:bind-program-pipeline (handle-value-of *active-shading-pipeline*))
            (gl:bind-program-pipeline 0)))))
 
 
 (defun use-shading-program-stages (pipeline program &rest stages)
-  (apply #'gl:use-program-stages (id-of pipeline) (id-of program) stages))
+  (apply #'gl:use-program-stages (handle-value-of pipeline) (handle-value-of program) stages))