forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
type-info.lisp
131 lines (124 loc) · 4.46 KB
/
type-info.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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
#|
This file is a part of trial
(c) 2016 Shirakumo http://tymoon.eu ([email protected])
Author: Nicolas Hafner <[email protected]>
|#
(in-package #:org.shirakumo.fraf.trial)
(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 32)) :uint)
((subtypep type '(signed-byte 32)) :int)
((subtypep type '(unsigned-byte 64)) :ulong)
((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 :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 'vec2)
(:vec3 'vec3)
(:vec4 '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)))
((: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))))
((: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))
(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) #+x86 4 #+x86-64 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))))