type-info.lisp

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

(defvar *dynamic-context*)

(defun check-integer-size (thing size &optional unsigned)
  (declare (type (unsigned-byte 8) size))
  (declare (optimize speed))
  (if unsigned
      (unless (<= 0 thing (expt 2 size))
        (error "~a does not fit within [0,2^~a]." thing size))
      (let ((size (1- size)))
        (unless (<= (- (expt 2 size)) thing (1- (expt 2 size)))
          (error "~a does not fit within [-2^~a,2^~:*~a-1]." thing size)))))

(define-constant-fold-function cl-type->gl-type (type)
  (cond ((eql type 'fixnum) :int)
        ((subtypep type '(signed-byte 8)) :char)
        ((subtypep type '(unsigned-byte 16)) :unsigned-short)
        ((subtypep type '(signed-byte 16)) :short)
        ((subtypep type '(unsigned-byte 32)) :unsigned-int)
        ((subtypep type '(signed-byte 32)) :int)
        ((subtypep type '(unsigned-byte 64)) :unsigned-long)
        ((subtypep type '(signed-byte 64)) :long)
        ((subtypep type 'single-float) :float)
        ((subtypep type 'double-float) :double)
        ((eql type 'vec2) :vec2)
        ((eql type 'vec3) :vec3)
        ((eql type 'vec4) :vec4)
        ((eql type 'mat2) :mat2)
        ((eql type 'mat3) :mat3)
        ((eql type 'mat4) :mat4)
        (T (error "Don't know how to convert ~s to a GL type." type))))

(define-constant-fold-function gl-type->cl-type (type)
  (ecase type
    ((:boolean :bool :ubyte :unsigned-byte :unsigned-char) '(unsigned-byte 8))
    ((:byte :char) '(signed-byte 8))
    ((:ushort :unsigned-short) '(unsigned-byte 16))
    (:short '(signed-byte 16))
    ((:uint :unsigend-int) '(unsigned-byte 32))
    ((:int :fixed :sizei :enum :bitfield) '(signed-byte 32))
    ((:uint64 :ulong :unsigned-long) '(unsigned-byte 64))
    ((:int64 :long) '(signed-byte 64))
    ((:half :half-float) 'short-float)
    ((:float :clampf) 'single-float)
    ((:double :clampd) 'double-float)
    ((:vec2 :uvec2 :ivec2) 'vec2)
    ((:vec3 :uvec3 :ivec3) 'vec3)
    ((:vec4 :uvec4 :ivec4) 'vec4)
    (:mat2 'mat2)
    (:mat3 'mat3)
    (:mat4 'mat4)))

(defun gl-coerce (thing type)
  (declare (optimize speed))
  (ecase type
    ((:double :double-float)
     (float thing 0.0d0))
    ((:float :single-float)
     (float thing 0.0f0))
    ((:int)
     #-elide-coercion-size-checks
     (check-integer-size thing 32)
     (values (round thing)))
    ((:uint :unsigned-int)
     #-elide-coercion-size-checks
     (check-integer-size thing 32 T)
     (values (round thing)))
    ((:short)
     #-elide-coercion-size-checks
     (check-integer-size thing 16)
     (values (round thing)))
    ((:ushort :unsigned-short)
     #-elide-coercion-size-checks
     (check-integer-size thing 16 T)
     (values (round thing)))
    ((:char :byte)
     #-elide-coercion-size-checks
     (check-integer-size thing 8)
     (values (round thing)))
    ((:uchar :unsigned-char :unsigned-byte)
     #-elide-coercion-size-checks
     (check-integer-size thing 8 T)
     (values (round thing)))))

(define-compiler-macro gl-coerce (&whole whole &environment env thing type)
  (if (constantp type env)
      `(funcall (load-time-value
                 (ecase ,type
                   ((:double :double-float)
                    (lambda (thing) (float thing 0.0d0)))
                   ((:float :single-float)
                    (lambda (thing) (float thing 0.0f0)))
                   ((:int)
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 32)
                      (values (round thing))))
                   ((:uint :unsigned-int)
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 32 T)
                      (values (round thing))))
                   (:short
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 16)
                      (values (round thing))))
                   ((:ushort :unsigned-short)
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 16 T)
                      (values (round thing))))
                   ((:char :byte)
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 8)
                      (values (round thing))))
                   ((:uchar :unsigned-char :unsigned-byte)
                    (lambda (thing)
                      #-elide-coercion-size-checks
                      (check-integer-size thing 8 T)
                      (values (round thing))))))
                ,thing)
      whole))

(declaim (ftype (function (keyword) (unsigned-byte 8)) gl-type-size))
(define-constant-fold-function gl-type-size (type)
  (ecase type
    (:boolean 1)
    ((:ubyte :unsigned-byte :byte :char) 1)
    ((:ushort :unsigned-short :short) 2)
    ((:uint :unsigned-int :int) 4)
    (:fixed 4)
    ((:ulong :unsigned-long :uint64 :int64) 8)
    (:sizei 4)
    (:enum 4)
    ((:intptr :sizeiptr :sync) #+32-bit 4 #+64-bit 8)
    (:bitfield 4)
    ((:half :half-float) 2)
    ((:float :clampf) 4)
    ((:double :clampd) 8)
    (:vec2 (* 2 4))
    (:vec3 (* 3 4))
    (:vec4 (* 4 4))
    (:mat2 (* 2 2 4))
    (:mat3 (* 3 3 4))
    (:mat4 (* 4 44))))

(defclass memory-layout-standard () ())
(defclass std140 (memory-layout-standard) ())
(defclass std430 (std140) ())
(defclass vertex-buffer (memory-layout-standard) ())

(defgeneric buffer-field-base (standard type)
  (:method (standard (type symbol))
    (buffer-field-base standard (find-class type)))
  (:method ((standard symbol) type)
    (buffer-field-base (type-prototype standard) type)))

(defgeneric buffer-field-size (standard type base)
  (:method (standard (type symbol) base)
    (buffer-field-size standard (find-class type) base))
  (:method ((standard symbol) type base)
    (buffer-field-size (type-prototype standard) type base)))

(defgeneric buffer-field-stride (standard type)
  (:method (standard (type symbol))
    (buffer-field-stride standard (find-class type)))
  (:method ((standard symbol) type)
    (buffer-field-stride (type-prototype standard) type)))

(defmethod buffer-field-base (standard (type (eql :uvec2))) (buffer-field-base standard :vec2))
(defmethod buffer-field-base (standard (type (eql :uvec3))) (buffer-field-base standard :vec3))
(defmethod buffer-field-base (standard (type (eql :uvec4))) (buffer-field-base standard :vec4))
(defmethod buffer-field-base (standard (type (eql :ivec2))) (buffer-field-base standard :vec2))
(defmethod buffer-field-base (standard (type (eql :ivec3))) (buffer-field-base standard :vec3))
(defmethod buffer-field-base (standard (type (eql :ivec4))) (buffer-field-base standard :vec4))
(defmethod buffer-field-size (standard (type (eql :uvec2)) base) (buffer-field-size standard :vec2 base))
(defmethod buffer-field-size (standard (type (eql :uvec3)) base) (buffer-field-size standard :vec3 base))
(defmethod buffer-field-size (standard (type (eql :uvec4)) base) (buffer-field-size standard :vec4 base))
(defmethod buffer-field-size (standard (type (eql :ivec2)) base) (buffer-field-size standard :vec2 base))
(defmethod buffer-field-size (standard (type (eql :ivec3)) base) (buffer-field-size standard :vec3 base))
(defmethod buffer-field-size (standard (type (eql :ivec4)) base) (buffer-field-size standard :vec4 base))
(defmethod buffer-field-stride (standard (type (eql :uvec2))) (buffer-field-stride standard :vec2))
(defmethod buffer-field-stride (standard (type (eql :uvec3))) (buffer-field-stride standard :vec3))
(defmethod buffer-field-stride (standard (type (eql :uvec4))) (buffer-field-stride standard :vec4))
(defmethod buffer-field-stride (standard (type (eql :ivec2))) (buffer-field-stride standard :vec2))
(defmethod buffer-field-stride (standard (type (eql :ivec3))) (buffer-field-stride standard :vec3))
(defmethod buffer-field-stride (standard (type (eql :ivec4))) (buffer-field-stride standard :vec4))

(defmethod buffer-field-base ((standard std140) (type (eql :int))) 4)
(defmethod buffer-field-base ((standard std140) (type (eql :uint))) 4)
(defmethod buffer-field-base ((standard std140) (type (eql :bool))) 4)
(defmethod buffer-field-base ((standard std430) (type (eql :bool))) 1)
(defmethod buffer-field-base ((standard std140) (type (eql :float))) 4)
(defmethod buffer-field-base ((standard std140) (type (eql :vec2))) 8)
(defmethod buffer-field-base ((standard std140) (type (eql :vec3))) 16)
(defmethod buffer-field-base ((standard std140) (type (eql :vec4))) 16)
(defmethod buffer-field-base ((standard std140) (type (eql :mat2))) (buffer-field-base standard :vec4))
(defmethod buffer-field-base ((standard std140) (type (eql :mat3))) (buffer-field-base standard :vec4))
(defmethod buffer-field-base ((standard std140) (type (eql :mat4))) (buffer-field-base standard :vec4))
(defmethod buffer-field-base ((standard std140) (type cons)) (buffer-field-base standard :vec4))

(defmethod buffer-field-size ((standard std140) (type (eql :int)) base) 4)
(defmethod buffer-field-size ((standard std140) (type (eql :uint)) base) 4)
(defmethod buffer-field-size ((standard std140) (type (eql :bool)) base) 4)
(defmethod buffer-field-size ((standard std430) (type (eql :bool)) base) 1)
(defmethod buffer-field-size ((standard std140) (type (eql :float)) base) 4)
(defmethod buffer-field-size ((standard std140) (type (eql :double)) base) 8)
(defmethod buffer-field-size ((standard std140) (type (eql :vec2)) base) 8)
(defmethod buffer-field-size ((standard std140) (type (eql :vec3)) base) 12)
(defmethod buffer-field-size ((standard std140) (type (eql :vec4)) base) 16)
(defmethod buffer-field-size ((standard std140) (type (eql :mat2)) base) (buffer-field-size standard '(:array :vec4 2) base))
(defmethod buffer-field-size ((standard std140) (type (eql :mat3)) base) (buffer-field-size standard '(:array :vec4 3) base))
(defmethod buffer-field-size ((standard std140) (type (eql :mat4)) base) (buffer-field-size standard '(:array :vec4 4) base))
(defmethod buffer-field-size ((standard std430) (type (eql :mat2)) base) (buffer-field-size standard '(:array :vec2 2) base))
(defmethod buffer-field-size ((standard std430) (type (eql :mat3)) base) (buffer-field-size standard '(:array :vec3 3) base))
(defmethod buffer-field-size ((standard std430) (type (eql :mat4)) base) (buffer-field-size standard '(:array :vec4 4) base))
(defmethod buffer-field-size ((standard std140) (type cons) base)
  (ecase (first type)
    (:struct (buffer-field-size standard (second type) base))
    (:array (destructuring-bind (identifier type count) type
              (declare (ignore identifier))
              (when (symbolp count)
                (setf count (slot-value *dynamic-context* count)))
              (if (listp type)
                  (* count (buffer-field-size standard type base))
                  (round-to
                   (buffer-field-base standard :vec4)
                   (* count (round-to (buffer-field-base standard :vec4)
                                      (buffer-field-size standard type 0)))))))))
(defmethod buffer-field-size ((standard std430) (type cons) base)
  (ecase (first type)
    (:struct (buffer-field-size standard (second type) base))
    (:array (destructuring-bind (identifier type count) type
              (declare (ignore identifier))
              (when (symbolp count)
                (setf count (slot-value *dynamic-context* count)))
              (* count (buffer-field-size standard type base))))))

(defmethod buffer-field-stride ((standard std140) (type (eql :int))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :int))) 4)
(defmethod buffer-field-stride ((standard std140) (type (eql :uint))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :uint))) 4)
(defmethod buffer-field-stride ((standard std140) (type (eql :bool))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :bool))) 1)
(defmethod buffer-field-stride ((standard std140) (type (eql :float))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :float))) 4)
(defmethod buffer-field-stride ((standard std140) (type (eql :vec2))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :vec2))) 8)
(defmethod buffer-field-stride ((standard std140) (type (eql :vec3))) 16)
(defmethod buffer-field-stride ((standard std430) (type (eql :vec3))) 12)
(defmethod buffer-field-stride ((standard std140) (type (eql :vec4))) 16)
(defmethod buffer-field-stride ((standard std140) (type (eql :mat2))) (* 2 (buffer-field-stride standard :vec4)))
(defmethod buffer-field-stride ((standard std430) (type (eql :mat2))) (* 2 2 (buffer-field-stride standard :float)))
(defmethod buffer-field-stride ((standard std140) (type (eql :mat3))) (* 3 (buffer-field-stride standard :vec4)))
(defmethod buffer-field-stride ((standard std430) (type (eql :mat3))) (* 3 3 (buffer-field-stride standard :float)))
(defmethod buffer-field-stride ((standard std140) (type (eql :mat4))) (* 4 (buffer-field-stride standard :vec4)))
(defmethod buffer-field-stride ((standard std430) (type (eql :mat4))) (* 4 4 (buffer-field-stride standard :float)))
(defmethod buffer-field-stride ((standard std140) (type cons))
  (ecase (first type)
    (:struct (buffer-field-size standard (second type) 0))))

(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :int))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :uint))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :bool))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :float))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :vec2))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :vec3))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :vec4))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :mat2))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :mat3))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type (eql :mat4))) 1)
(defmethod buffer-field-base ((standard vertex-buffer) (type cons))
  (ecase (first type)
    (:struct (buffer-field-base standard (second type)))))

(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :int)) base) 4)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :uint)) base) 4)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :bool)) base) 1)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :float)) base) 4)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :vec2)) base) 8)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :vec3)) base) 12)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :vec4)) base) 16)
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :mat2)) base) (* 2 2 4))
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :mat3)) base) (* 3 3 4))
(defmethod buffer-field-size ((standard vertex-buffer) (type (eql :mat4)) base) (* 4 4 4))
(defmethod buffer-field-size ((standard vertex-buffer) (type cons) base)
  (ecase (first type)
    (:struct (buffer-field-size standard (second type) base))))

(defmethod buffer-field-stride ((standard vertex-buffer) type) (buffer-field-size standard type 0))
(defmethod buffer-field-stride ((standard std140) (type cons))
  (ecase (first type)
    (:struct (buffer-field-size standard (second type) 0))))

(declaim (inline gl-memref-std140))
(defun gl-memref-std140 (ptr type &optional container)
  (flet ((%ref (i)  (cffi:mem-aref ptr :float i))
         (%iref (i) (cffi:mem-aref ptr :int32 i))
         (%uref (i) (cffi:mem-aref ptr :uint32 i)))
    (declare (inline %ref %iref %uref))
    (ecase type
      (:int (cffi:mem-ref ptr :int))
      (:uint (cffi:mem-ref ptr :uint))
      (:bool (< 0 (cffi:mem-ref ptr :int)))
      (:float (cffi:mem-ref ptr :float))
      (:double (cffi:mem-ref ptr :double))
      (:vec2 (unless container (setf container (vec2)))
       (vsetf container (%ref 0) (%ref 1)))
      (:vec3 (unless container (setf container (vec3)))
       (vsetf container (%ref 0) (%ref 1) (%ref 2)))
      (:vec4 (unless container (setf container (vec4)))
       (vsetf container (%ref 0) (%ref 1) (%ref 2) (%ref 3)))
      (:ivec2 (unless container (setf container (vec2)))
       (vsetf container (%iref 0) (%iref 1)))
      (:ivec3 (unless container (setf container (vec3)))
       (vsetf container (%iref 0) (%iref 1) (%iref 2)))
      (:ivec4 (unless container (setf container (vec4)))
       (vsetf container (%iref 0) (%iref 1) (%iref 2) (%iref 3)))
      (:uvec2 (unless container (setf container (vec2)))
       (vsetf container (%iref 0) (%uref 1)))
      (:uvec3 (unless container (setf container (vec3)))
       (vsetf container (%uref 0) (%uref 1) (%uref 2)))
      (:uvec4 (unless container (setf container (vec4)))
       (vsetf container (%uref 0) (%uref 1) (%uref 2) (%uref 3)))
      (:mat2 (unless container (setf container (mat2)))
       (msetf container
              (%ref 0) (%ref 1)
              (%ref 4) (%ref 5)))
      (:mat3 (unless container (setf container (mat3)))
       (msetf container
              (%ref 0) (%ref 1) (%ref 2)
              (%ref 4) (%ref 5) (%ref 6)
              (%ref 8) (%ref 9) (%ref 10)))
      (:mat4 (unless container (setf container (mat4)))
       (cffi:with-pointer-to-vector-data (dst (marr4 container))
         (static-vectors:replace-foreign-memory dst ptr (* 4 4 4)))))))

(declaim (inline gl-memref-std430))
(defun gl-memref-std430 (ptr type &optional container)
  (flet ((%ref (i)  (cffi:mem-aref ptr :float i))
         (%iref (i) (cffi:mem-aref ptr :int32 i))
         (%uref (i) (cffi:mem-aref ptr :uint32 i)))
    (declare (inline %ref %iref %uref))
    (ecase type
      (:int (cffi:mem-ref ptr :int))
      (:uint (cffi:mem-ref ptr :uint))
      (:bool (< 0 (cffi:mem-ref ptr :int)))
      (:float (cffi:mem-ref ptr :float))
      (:double (cffi:mem-ref ptr :double))
      (:vec2 (unless container (setf container (vec2)))
       (vsetf container (%ref 0) (%ref 1)))
      (:vec3 (unless container (setf container (vec3)))
       (vsetf container (%ref 0) (%ref 1) (%ref 2)))
      (:vec4 (unless container (setf container (vec4)))
       (vsetf container (%ref 0) (%ref 1) (%ref 2) (%ref 3)))
      (:ivec2 (unless container (setf container (vec2)))
       (vsetf container (%iref 0) (%iref 1)))
      (:ivec3 (unless container (setf container (vec3)))
       (vsetf container (%iref 0) (%iref 1) (%iref 2)))
      (:ivec4 (unless container (setf container (vec4)))
       (vsetf container (%iref 0) (%iref 1) (%iref 2) (%iref 3)))
      (:uvec2 (unless container (setf container (vec2)))
       (vsetf container (%iref 0) (%uref 1)))
      (:uvec3 (unless container (setf container (vec3)))
       (vsetf container (%uref 0) (%uref 1) (%uref 2)))
      (:uvec4 (unless container (setf container (vec4)))
       (vsetf container (%uref 0) (%uref 1) (%uref 2) (%uref 3)))
      (:mat2 (unless container (setf container (mat2)))
       (cffi:with-pointer-to-vector-data (dst (marr2 container))
         (static-vectors:replace-foreign-memory dst ptr (* 2 2 4))))
      (:mat3 (unless container (setf container (mat3)))
       (cffi:with-pointer-to-vector-data (dst (marr3 container))
         (static-vectors:replace-foreign-memory dst ptr (* 3 3 4))))
      (:mat4 (unless container (setf container (mat4)))
       (cffi:with-pointer-to-vector-data (dst (marr4 container))
         (static-vectors:replace-foreign-memory dst ptr (* 4 4 4)))))))

(declaim (inline gl-memref))
(defun gl-memref (ptr type &key (layout 'std140) container)
  (etypecase layout
    ((or std430 (eql std430)) (gl-memref-std430 ptr type container))
    ((or std140 (eql std140)) (gl-memref-std140 ptr type container))))

(declaim (inline (setf gl-memref-std140)))
(defun (setf gl-memref-std140) (value ptr type)
  (flet (((setf %ref) (value i) (setf (cffi:mem-aref ptr :float i) value))
         ((setf %iref) (value i) (setf (cffi:mem-aref ptr :int32 i) value))
         ((setf %uref) (value i) (setf (cffi:mem-aref ptr :uint32 i) value)))
    (declare (inline (setf %ref) (setf %iref) (setf %uref)))
    (ecase type
      (:int
       (setf (cffi:mem-ref ptr :int) value))
      (:uint
       (setf (cffi:mem-ref ptr :uint) value))
      (:bool
       (setf (cffi:mem-ref ptr :int) (if value 1 0)))
      (:float
       (setf (cffi:mem-ref ptr :float) value))
      (:double
       (setf (cffi:mem-ref ptr :double) value))
      (:vec2
       (setf (%ref 0) (vx2 value))
       (setf (%ref 1) (vy2 value)))
      (:vec3
       (setf (%ref 0) (vx3 value))
       (setf (%ref 1) (vy3 value))
       (setf (%ref 2) (vz3 value)))
      (:vec4
       (setf (%ref 0) (vx4 value))
       (setf (%ref 1) (vy4 value))
       (setf (%ref 2) (vz4 value))
       (setf (%ref 3) (vw4 value)))
      (:ivec2
       (setf (%iref 0) (truncate (vx2 value)))
       (setf (%iref 1) (truncate (vy2 value))))
      (:ivec3
       (setf (%iref 0) (truncate (vx3 value)))
       (setf (%iref 1) (truncate (vy3 value)))
       (setf (%iref 2) (truncate (vz3 value))))
      (:ivec4
       (setf (%iref 0) (truncate (vx4 value)))
       (setf (%iref 1) (truncate (vy4 value)))
       (setf (%iref 2) (truncate (vz4 value)))
       (setf (%iref 3) (truncate (vw4 value))))
      (:uvec2
       (setf (%uref 0) (truncate (vx2 value)))
       (setf (%uref 1) (truncate (vy2 value))))
      (:uvec3
       (setf (%uref 0) (truncate (vx3 value)))
       (setf (%uref 1) (truncate (vy3 value)))
       (setf (%uref 2) (truncate (vz3 value))))
      (:uvec4
       (setf (%uref 0) (truncate (vx4 value)))
       (setf (%uref 1) (truncate (vy4 value)))
       (setf (%uref 2) (truncate (vz4 value)))
       (setf (%uref 3) (truncate (vw4 value))))
      (:mat2
       (loop with idx = #(0 1 4 5)
             for i from 0 below 4
             do (setf (%ref (aref idx i)) (miref value i))))
      (:mat3
       (loop with idx = #(0 1 2 4 5 6 8 9 10)
             for i from 0 below 9
             do (setf (%ref (aref idx i)) (miref value i))))
      (:mat4
       (cffi:with-pointer-to-vector-data (src (marr4 value))
         (static-vectors:replace-foreign-memory ptr src (* 4 4 4))))))
  value)

(declaim (inline (setf gl-memref-std430)))
(defun (setf gl-memref-std430) (value ptr type)
  (flet (((setf %ref) (value i) (setf (cffi:mem-aref ptr :float i) value))
         ((setf %iref) (value i) (setf (cffi:mem-aref ptr :int32 i) value))
         ((setf %uref) (value i) (setf (cffi:mem-aref ptr :uint32 i) value)))
    (declare (inline (setf %ref) (setf %iref) (setf %uref)))
    (ecase type
      (:int
       (setf (cffi:mem-ref ptr :int) value))
      (:uint
       (setf (cffi:mem-ref ptr :uint) value))
      (:bool
       (setf (cffi:mem-ref ptr :char) (if value 1 0)))
      (:float
       (setf (cffi:mem-ref ptr :float) value))
      (:double
       (setf (cffi:mem-ref ptr :double) value))
      (:vec2
       (setf (%ref 0) (vx2 value))
       (setf (%ref 1) (vy2 value)))
      (:vec3
       (setf (%ref 0) (vx3 value))
       (setf (%ref 1) (vy3 value))
       (setf (%ref 2) (vz3 value)))
      (:vec4
       (setf (%ref 0) (vx4 value))
       (setf (%ref 1) (vy4 value))
       (setf (%ref 2) (vz4 value))
       (setf (%ref 3) (vw4 value)))
      (:ivec2
       (setf (%iref 0) (truncate (vx2 value)))
       (setf (%iref 1) (truncate (vy2 value))))
      (:ivec3
       (setf (%iref 0) (truncate (vx3 value)))
       (setf (%iref 1) (truncate (vy3 value)))
       (setf (%iref 2) (truncate (vz3 value))))
      (:ivec4
       (setf (%iref 0) (truncate (vx4 value)))
       (setf (%iref 1) (truncate (vy4 value)))
       (setf (%iref 2) (truncate (vz4 value)))
       (setf (%iref 3) (truncate (vw4 value))))
      (:uvec2
       (setf (%uref 0) (truncate (vx2 value)))
       (setf (%uref 1) (truncate (vy2 value))))
      (:uvec3
       (setf (%uref 0) (truncate (vx3 value)))
       (setf (%uref 1) (truncate (vy3 value)))
       (setf (%uref 2) (truncate (vz3 value))))
      (:uvec4
       (setf (%uref 0) (truncate (vx4 value)))
       (setf (%uref 1) (truncate (vy4 value)))
       (setf (%uref 2) (truncate (vz4 value)))
       (setf (%uref 3) (truncate (vw4 value))))
      (:mat2
       (cffi:with-pointer-to-vector-data (src (marr2 value))
         (static-vectors:replace-foreign-memory ptr src (* 2 2 4))))
      (:mat3
       (cffi:with-pointer-to-vector-data (src (marr3 value))
         (static-vectors:replace-foreign-memory ptr src (* 3 3 4))))
      (:mat4
       (cffi:with-pointer-to-vector-data (src (marr4 value))
         (static-vectors:replace-foreign-memory ptr src (* 4 4 4))))))
  value)

(declaim (inline (setf gl-memref)))
(defun (setf gl-memref) (value ptr type &key (layout 'std140))
  (etypecase layout
    ((or std430 (eql std430)) (setf (gl-memref-std430 ptr type) value))
    ((or std140 (eql std140)) (setf (gl-memref-std140 ptr type) value))))