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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
|
(in-package #:cmamut)
; Ideas:
; Generate code that creates a package and puts all definitions there.
; If symbol names are unaltered we can skip connecting everything together.
; To avoid collisions the created package shouldn't import any symbols.
; Maybe use straight defuns and ffi functions to get as close as possible to the C names without much work.
; Only define functions from the target library, but get all other definitions.
; TODO: Get constants from macro file generated by c2ffi -M
; TODO: Use c2ffi to extract the spec.json using the header file as parameter
(defvar reference-table (make-hash-table :test #'equal :size 256))
(defun get-spec ()
(json:from-file "~/common-lisp/cmamut/spec.json"))
(defun cook-type (raw-type)
(let ((tag (gethash "tag" raw-type)))
(cond ((string= tag ":void")
'sb-alien:void)
((string= tag ":function-pointer")
'sb-alien:function)
((string= tag ":pointer")
(let ((pointed-type (gethash "type" raw-type)))
(if (string= (gethash "tag" pointed-type) ":char")
'sb-alien:c-string
(list 'sb-alien:* (cook-type pointed-type)))))
((string= tag ":float")
'sb-alien:float)
((string= tag ":double")
'sb-alien:double)
((string= tag ":unsigned-char")
'sb-alien:unsigned-char)
((string= tag ":unsigned-short")
'sb-alien:unsigned-short)
((string= tag ":unsigned-int")
'sb-alien:unsigned-int)
((string= tag ":unsigned-long")
'sb-alien:unsigned-long)
((string= tag ":char")
'sb-alien:char)
((string= tag ":short")
'sb-alien:short)
((string= tag ":int")
'sb-alien:int)
((string= tag ":long")
'sb-alien:long)
((string= tag ":array")
(cook-array raw-type))
((string= tag ":struct")
(list 'sb-alien:struct (gethash "name" raw-type)))
((string= tag ":union")
(list 'sb-alien:union (gethash "name" raw-type)))
((string= tag "struct")
(cook-struct raw-type))
((string= tag "union")
(cook-union raw-type))
(t tag))))
(defun cook-array (raw-array)
`(sb-alien:array
,(cook-type (gethash "type" raw-array))
,(gethash "size" raw-array)))
(defun cook-function (raw-function &optional name-transformer)
(let ((raw-params (gethash "parameters" raw-function))
(cooked-params (queue:new)))
(dotimes (j (length raw-params))
(queue:add cooked-params
(list (intern (string-upcase (gethash "name" (aref raw-params j))))
(cook-type (gethash "type" (aref raw-params j))))))
`(sb-alien:define-alien-routine
,(let ((function-name (gethash "name" raw-function)))
(if name-transformer
(list function-name (funcall name-transformer function-name))
function-name))
,(cook-type (gethash "return-type" raw-function))
,@(queue:to-list cooked-params))))
(defun cook-typedef (raw-typedef)
(let* ((base-type (gethash "type" raw-typedef))
(new-name (gethash "name" raw-typedef))
(enum? (string= (gethash "tag" base-type) ":enum")))
(when enum?
(setf (gethash (gethash "id" base-type) reference-table)
new-name))
`(sb-alien:define-alien-type
,new-name
,(if enum?
`(sb-alien:enum ,new-name)
(cook-type base-type)))))
(defun cook-struct (raw-struct)
(let ((raw-fields (gethash "fields" raw-struct))
(cooked-fields (queue:new)))
(dotimes (j (length raw-fields))
(queue:add cooked-fields
(list (intern (string-upcase (gethash "name" (aref raw-fields j))))
(cook-type (gethash "type" (aref raw-fields j))))))
`(sb-alien:struct
,(gethash "name" raw-struct)
,@(queue:to-list cooked-fields))))
(defun cook-union (raw-union)
(let ((raw-fields (gethash "fields" raw-union))
(cooked-fields (queue:new)))
(dotimes (j (length raw-fields))
(queue:add cooked-fields
(list (intern (string-upcase (gethash "name" (aref raw-fields j))))
(cook-type (gethash "type" (aref raw-fields j))))))
`(sb-alien:union
,(gethash "name" raw-union)
,@(queue:to-list cooked-fields))))
(defun cook-enum (raw-enum)
(let ((name (gethash (gethash "id" raw-enum) reference-table))
(raw-fields (gethash "fields" raw-enum))
(cooked-fields (queue:new)))
(dotimes (j (length raw-fields))
(queue:add cooked-fields
(list (intern (string-upcase (gethash "name" (aref raw-fields j))))
(gethash "value" (aref raw-fields j)))))
`(sb-alien:define-alien-type
nil
(sb-alien:enum
,name
,@(queue:to-list cooked-fields)))))
(defstruct spec
functions
typedefs
structs
unions
enums)
(defun prepare-spec (spec)
(clrhash reference-table)
(let ((s (make-spec)))
(dotimes (i (length spec))
(cond ((string= (gethash "tag" (aref spec i)) "function")
(push (aref spec i) (spec-functions s)))
((string= (gethash "tag" (aref spec i)) "typedef")
(push (aref spec i) (spec-typedefs s)))
((string= (gethash "tag" (aref spec i)) "struct")
(push (aref spec i) (spec-structs s)))
((string= (gethash "tag" (aref spec i)) "enum")
(push (aref spec i) (spec-enums s)))
((string= (gethash "tag" (aref spec i)) "union")
(push (aref spec i) (spec-unions s)))
(t)))
; typedefs must be generated first to build the reference table
(setf (spec-typedefs s) (mapcar #'cook-typedef (spec-typedefs s)))
(setf (spec-functions s) (mapcar #'cook-function (spec-functions s)))
(setf (spec-enums s) (mapcar #'cook-enum (spec-enums s)))
(setf (spec-structs s)
(mapcar (lambda (x)
`(sb-alien:define-alien-type nil ,(cook-struct x)))
(spec-structs s)))
(setf (spec-unions s)
(mapcar (lambda (x)
`(sb-alien:define-alien-type nil ,(cook-union x)))
(spec-unions s)))
s))
(defun to-file (spec filename)
(with-open-file (f filename
:direction :output
:if-exists :overwrite
:if-does-not-exist :create)
(princ ";;; GENERATED BY CMAMUT" f)
(terpri f)
(format f "~{~s~&~}" (spec-enums spec))
(format f "~{~s~&~}" (spec-typedefs spec))
(format f "~{~s~&~}" (spec-structs spec))
(format f "~{~s~&~}" (spec-unions spec))
(format f "~{~s~&~}" (spec-functions spec))))
|
