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 :unsigned-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)))))

(defun gl-coercion-fun (type)
  (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))))))

(define-compiler-macro gl-coerce (&whole whole &environment env thing type)
  (if (constantp type env)
      `(funcall (load-time-value (gl-coercion-fun ,type)) ,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)))
    (declare (inline %ref))
    (ecase type
      (:int
       (cffi:mem-ref ptr :int))
      ((:uint :unsigned-int :unsigned-int-atomic-counter)
       (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 :float-vec2)
       (unless container (setf container (vec2)))
       (mem:replace (varr2 container) ptr)
       container)
      ((:vec3 :float-vec3)
       (unless container (setf container (vec3)))
       (mem:replace (varr3 container) ptr)
       container)
      ((:vec4 :float-vec4)
       (unless container (setf container (vec4)))
       (mem:replace (varr4 container) ptr)
       container)
      ((:dvec2 :double-vec2)
       (unless container (setf container (dvec2)))
       (mem:replace (dvarr2 container) ptr)
       container)
      ((:dvec3 :double-vec3)
       (unless container (setf container (dvec3)))
       (mem:replace (dvarr3 container) ptr)
       container)
      ((:dvec4 :double-vec4)
       (unless container (setf container (dvec4)))
       (mem:replace (dvarr4 container) ptr)
       container)
      ((:ivec2 :int-vec2)
       (unless container (setf container (ivec2)))
       (mem:replace (ivarr2 container) ptr)
       container)
      ((:ivec3 :int-vec3)
       (unless container (setf container (ivec3)))
       (mem:replace (ivarr3 container) ptr)
       container)
      ((:ivec4 :int-vec4)
       (unless container (setf container (ivec4)))
       (mem:replace (ivarr4 container) ptr)
       container)
      ((:uvec2 :unsigned-int-vec2)
       (unless container (setf container (uvec2)))
       (mem:replace (uvarr2 container) ptr)
       container)
      ((:uvec3 :unsigned-int-vec3)
       (unless container (setf container (uvec3)))
       (mem:replace (uvarr3 container) ptr)
       container)
      ((:uvec4 :unsigned-int-vec4)
       (unless container (setf container (uvec4)))
       (mem:replace (uvarr4 container) ptr)
       container)
      ((:mat2 :float-mat2) 
       (unless container (setf container (mat2)))
       (msetf container
              (%ref 0) (%ref 1)
              (%ref 4) (%ref 5)))
      ((:mat3 :float-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 :float-mat4)
       (unless container (setf container (mat4)))
       (mem:replace (marr4 container) ptr)
       container))))

(declaim (inline gl-memref-std430))
(defun gl-memref-std430 (ptr type &optional container)
  (ecase type
    (:int
     (cffi:mem-ref ptr :int))
    ((:uint :unsigned-int :unsigned-int-atomic-counter)
     (cffi:mem-ref ptr :uint))
    (:bool
     (< 0 (cffi:mem-ref ptr :char)))
    (:float
     (cffi:mem-ref ptr :float))
    (:double
     (cffi:mem-ref ptr :double))
    ((:vec2 :float-vec2)
     (unless container (setf container (vec2)))
     (mem:replace (varr2 container) ptr)
     container)
    ((:vec3 :float-vec3)
     (unless container (setf container (vec3)))
     (mem:replace (varr3 container) ptr)
     container)
    ((:vec4 :float-vec4)
     (unless container (setf container (vec4)))
     (mem:replace (varr4 container) ptr)
     container)
    ((:dvec2 :double-vec2)
     (unless container (setf container (dvec2)))
     (mem:replace (dvarr2 container) ptr)
     container)
    ((:dvec3 :double-vec3)
     (unless container (setf container (dvec3)))
     (mem:replace (dvarr3 container) ptr)
     container)
    ((:dvec4 :double-vec4)
     (unless container (setf container (dvec4)))
     (mem:replace (dvarr4 container) ptr)
     container)
    ((:ivec2 :int-vec2)
     (unless container (setf container (ivec2)))
     (mem:replace (ivarr2 container) ptr)
     container)
    ((:ivec3 :int-vec3)
     (unless container (setf container (ivec3)))
     (mem:replace (ivarr3 container) ptr)
     container)
    ((:ivec4 :int-vec4)
     (unless container (setf container (ivec4)))
     (mem:replace (ivarr4 container) ptr)
     container)
    ((:uvec2 :unsigned-int-vec2)
     (unless container (setf container (uvec2)))
     (mem:replace (uvarr2 container) ptr)
     container)
    ((:uvec3 :unsigned-int-vec3)
     (unless container (setf container (uvec3)))
     (mem:replace (uvarr3 container) ptr)
     container)
    ((:uvec4 :unsigned-int-vec4)
     (unless container (setf container (uvec4)))
     (mem:replace (uvarr4 container) ptr)
     container)
    ((:mat2 :float-mat2)
     (unless container (setf container (mat2)))
     (mem:replace (marr2 container) ptr)
     container)
    ((:mat3 :float-mat3)
     (unless container (setf container (mat3)))
     (mem:replace (marr3 container) ptr)
     container)
    ((:mat4 :float-mat4)
     (unless container (setf container (mat4)))
     (mem:replace (marr4 container) ptr)
     container)
    ((:dmat2 :double-mat2)
     (unless container (setf container (dmat2)))
     (mem:replace (dmarr2 container) ptr)
     container)
    ((:dmat3 :double-mat3)
     (unless container (setf container (dmat3)))
     (mem:replace (dmarr3 container) ptr)
     container)
    ((:dmat4 :double-mat4)
     (unless container (setf container (dmat4)))
     (mem:replace (dmarr4 container) ptr)
     container)))

(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 :unsigned-int :unsigned-int-atomic-counter)
       (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 :float-vec2)
       (mem:replace ptr (varr2 value)))
      ((:vec3 :float-vec3)
       (mem:replace ptr (varr3 value)))
      ((:vec4 :float-vec4)
       (mem:replace ptr (varr4 value)))
      ((:ivec2 :int-vec2)
       (setf (%iref 0) (truncate (vx2 value)))
       (setf (%iref 1) (truncate (vy2 value))))
      ((:ivec3 :int-vec3)
       (setf (%iref 0) (truncate (vx3 value)))
       (setf (%iref 1) (truncate (vy3 value)))
       (setf (%iref 2) (truncate (vz3 value))))
      ((:ivec4 :int-vec4)
       (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 :unsigned-int-vec2)
       (setf (%uref 0) (truncate (vx2 value)))
       (setf (%uref 1) (truncate (vy2 value))))
      ((:uvec3 :unsigned-int-vec3)
       (setf (%uref 0) (truncate (vx3 value)))
       (setf (%uref 1) (truncate (vy3 value)))
       (setf (%uref 2) (truncate (vz3 value))))
      ((:uvec4 :unsigned-int-vec4)
       (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 :float-mat2)
       (loop with idx = #(0 1 4 5)
             for i from 0 below 4
             do (setf (%ref (aref idx i)) (miref value i))))
      ((:mat3 :float-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 :float-mat4)
       (mem:replace ptr (marr4 value)))))
  value)

(declaim (inline (setf gl-memref-std430)))
(defun (setf gl-memref-std430) (value ptr type)
  (flet (((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 %iref) (setf %uref)))
    (ecase type
      (:int
       (setf (cffi:mem-ref ptr :int) value))
      ((:uint :unsigned-int :unsigned-int-atomic-counter)
       (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 :float-vec2)
       (mem:replace ptr (varr2 value)))
      ((:vec3 :float-vec3)
       (mem:replace ptr (varr3 value)))
      ((:vec4 :float-vec4)
       (mem:replace ptr (varr4 value)))
      ((:ivec2 :int-vec2)
       (setf (%iref 0) (truncate (vx2 value)))
       (setf (%iref 1) (truncate (vy2 value))))
      ((:ivec3 :int-vec3)
       (setf (%iref 0) (truncate (vx3 value)))
       (setf (%iref 1) (truncate (vy3 value)))
       (setf (%iref 2) (truncate (vz3 value))))
      ((:ivec4 :int-vec4)
       (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 :unsigned-int-vec2)
       (setf (%uref 0) (truncate (vx2 value)))
       (setf (%uref 1) (truncate (vy2 value))))
      ((:uvec3 :unsigned-int-vec3)
       (setf (%uref 0) (truncate (vx3 value)))
       (setf (%uref 1) (truncate (vy3 value)))
       (setf (%uref 2) (truncate (vz3 value))))
      ((:uvec4 :unsigned-int-vec4)
       (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 :float-mat2)
       (mem:replace ptr (marr2 value)))
      ((:mat3 :float-mat3)
       (mem:replace ptr (marr3 value)))
      ((:mat4 :float-mat4)
       (mem:replace ptr (marr4 value)))
      ((:dmat2 :double-mat2)
       (mem:replace ptr (dmarr2 value)))
      ((:dmat3 :double-mat3)
       (mem:replace ptr (dmarr3 value)))
      ((:dmat4 :double-mat4)
       (mem:replace ptr (dmarr4 value)))))
  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))))

(defun normalize-gl-type (type)
  (case type
    (:sampler-1d-arb :sampler-1d)
    (:sampler-2d-arb :sampler-2d)
    (:sampler-3d-arb :sampler-3d)
    (:float-vec2-arb :float-vec2)
    (:float-vec3-arb :float-vec3)
    (:float-vec4-arb :float-vec4)
    (:float-mat2-arb :float-mat2)
    (:float-mat3-arb :float-mat3)
    (:float-mat4-arb :float-mat4)
    (T type)))