Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[4898ef]: contrib / sb-grovel / foreign-glue.lisp Maximize Restore History

Download this file

foreign-glue.lisp    395 lines (341 with data), 15.5 kB

  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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
(in-package :sb-grovel)
;;;; The macros defined here are called from #:Gconstants.lisp, which was
;;;; generated from constants.lisp by the C compiler as driven by that
;;;; wacky def-to-lisp thing.
;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
;;; C-CALL:C-STRING) (BUF (* T)) )
;;; I can't help thinking this was originally going to do something a
;;; lot more complex
(defmacro define-foreign-routine
(&whole it (c-name lisp-name) return-type &rest args)
(declare (ignorable c-name lisp-name return-type args))
`(define-alien-routine ,@(cdr it)))
;;; strctures
#| C structs need: the with-... interface.
|#
;;; global XXXs:
#|
XXX: :distrust-length t fields are dangerous. they should only be at
the end of the structure (they mess up offset/size calculations)
|#
(defun reintern (symbol &optional (package *package*))
(if (symbolp symbol)
(intern (symbol-name symbol) package)
symbol))
(defparameter alien-type-table (make-hash-table :test 'eql))
(defparameter lisp-type-table (make-hash-table :test 'eql))
(macrolet ((define-alien-types ((type size) &rest defns)
`(progn
,@(loop for defn in defns
collect (destructuring-bind (expected-type c-type lisp-type) defn
`(progn
(setf (gethash ',expected-type alien-type-table)
(lambda (,type ,size)
(declare (ignorable type size))
,c-type))
(setf (gethash ',expected-type lisp-type-table)
(lambda (,type ,size)
(declare (ignorable type size))
,lisp-type))))))))
(define-alien-types (type size)
(integer (or (gethash size (symbol-value (intern "*INTEGER-SIZES*")))
`(integer ,(* 8 size)))
`(unsigned-byte ,(* 8 size)))
(unsigned `(unsigned ,(* 8 size))
`(unsigned-byte ,(* 8 size)))
(signed `(signed ,(* 8 size))
`(signed-byte ,(* 8 size)))
(c-string `(array char ,size) 'cl:simple-string)
(c-string-pointer 'c-string 'cl:simple-string)
;; TODO: multi-dimensional arrays, if they are ever needed.
(array (destructuring-bind (array-tag elt-type &optional array-size) type
(declare (ignore array-tag))
;; XXX: use of EVAL. alien-size is a macro,
;; unfortunately; and it will only accept unquoted type
;; forms.
`(sb-alien:array ,elt-type ,(or array-size
(/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
t)))
(defun retrieve-type-for (type size table)
(multiple-value-bind (type-fn found)
(gethash (reintern (typecase type
(list (first type))
(t type))
(find-package '#:sb-grovel))
table)
(values
(if found
(funcall (the function type-fn) type size)
type)
found)))
(defun alien-type-for (type size)
(reintern (retrieve-type-for type size alien-type-table)))
(defun lisp-type-for (type size)
(multiple-value-bind (val found)
(retrieve-type-for type size lisp-type-table)
(if found
val
t)))
(defun mk-padding (len offset)
(make-instance 'padding
:type `(array char ,len)
:offset offset
:size len
:name (gentemp "PADDING")))
(defun mk-struct (offset &rest children)
(make-instance 'struct :name (gentemp "STRUCT")
:children (remove nil children)
:offset offset))
(defun mk-union (offset &rest children)
(make-instance 'union :name (gentemp "UNION")
:children (remove nil children)
:offset offset))
(defun mk-val (name type h-type offset size)
(declare (ignore h-type))
(make-instance 'value-slot :name name
:size size
:offset offset
:type type))
;;; struct tree classes
(defclass slot ()
((offset :initarg :offset :reader offset)
(name :initarg :name :reader name)))
(defclass structured-type (slot)
((children :initarg :children :accessor children)))
(defclass union (structured-type)
())
(defclass struct (structured-type)
())
(defclass value-slot (slot)
((size :initarg :size :reader size)
(type :initarg :type :reader type)))
(defclass padding (value-slot)
())
(defmethod print-object ((o value-slot) s)
(print-unreadable-object (o s :type t)
(format s "~S ~A+~A=~A" (name o) (offset o) (size o) (slot-end o))))
(defmethod print-object ((o structured-type) s)
(print-unreadable-object (o s :type t)
(format s "~S ~A" (name o) (children o))))
(defmethod size ((slot structured-type))
(let ((min-offset (offset slot)))
(if (null (children slot))
0
(reduce #'max (mapcar (lambda (child)
(+ (- (offset child) min-offset) (size child)))
(children slot))
:initial-value 0))))
(defgeneric slot-end (slot))
(defmethod slot-end ((slot slot))
(+ (offset slot) (size slot)))
(defun overlap-p (elt1 elt2)
(unless (or (zerop (size elt1))
(zerop (size elt2)))
(or
(and (<= (offset elt1)
(offset elt2))
(< (offset elt2)
(slot-end elt1)))
(and (<= (offset elt2)
(offset elt1))
(< (offset elt1)
(slot-end elt2))))))
(defgeneric find-overlaps (root new-element))
(defmethod find-overlaps ((root structured-type) new-element)
(when (overlap-p root new-element)
(let ((overlapping-elts (loop for child in (children root)
for overlap = (find-overlaps child new-element)
when overlap
return overlap)))
(cons root overlapping-elts))))
(defmethod find-overlaps ((root value-slot) new-element)
(when (overlap-p root new-element)
(list root)))
(defgeneric pad-to-offset-of (to-pad parent))
(macrolet ((skel (end-form)
`(let* ((end ,end-form)
(len (abs (- (offset to-pad) end))))
(cond
((= end (offset to-pad)) ; we are at the right offset.
nil)
(t ; we have to pad between the
; old slot's end and the new
; slot's offset
(mk-padding len end))))))
(defmethod pad-to-offset-of (to-pad (parent struct))
(skel (if (null (children parent))
0
(+ (size parent) (offset parent)))))
(defmethod pad-to-offset-of (to-pad (parent union))
(skel (if (null (children parent))
(offset to-pad)
(offset parent)))))
(defgeneric replace-by-union (in-st element new-element))
(defmethod replace-by-union ((in-st struct) elt new-elt)
(setf (children in-st) (remove elt (children in-st)))
(let ((padding (pad-to-offset-of new-elt in-st)))
(setf (children in-st)
(nconc (children in-st)
(list (mk-union (offset elt)
elt
(if padding
(mk-struct (offset elt)
padding
new-elt)
new-elt)))))))
(defmethod replace-by-union ((in-st union) elt new-elt)
(let ((padding (pad-to-offset-of new-elt in-st)))
(setf (children in-st)
(nconc (children in-st)
(list (if padding
(mk-struct (offset in-st)
padding
new-elt)
new-elt))))))
(defgeneric insert-element (root new-elt))
(defmethod insert-element ((root struct) (new-elt slot))
(let ((overlaps (find-overlaps root new-elt)))
(cond
(overlaps (let ((last-structure (first (last overlaps 2)))
(last-val (first (last overlaps))))
(replace-by-union last-structure last-val new-elt)
root))
(t
(let ((padding (pad-to-offset-of new-elt root)))
(setf (children root)
(nconc (children root)
(when padding (list padding))
(list new-elt)))))))
root)
(defun sane-slot (alien-var &rest slots)
"Emulates the SB-ALIEN:SLOT interface, with useful argument order for
deeply nested structures."
(labels ((rewriter (slots)
(if (null slots)
alien-var
`(sb-alien:slot ,(rewriter (rest slots))
',(first slots)))))
(rewriter slots)))
(defgeneric accessor-modifier-for (element-type accessor-type))
(defmacro identity-1 (thing &rest ignored)
(declare (ignore ignored))
thing)
(defun (setf identity-1) (new-thing place &rest ignored)
(declare (ignore ignored))
(setf place new-thing))
(defmethod accessor-modifier-for (element-type (accessor-type (eql :getter)))
'identity-1)
(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
(accessor-type (eql :getter)))
'c-string->lisp-string)
(defmethod accessor-modifier-for (element-type (accessor-type (eql :setter)))
nil)
(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
(accessor-type (eql :setter)))
'c-string->lisp-string)
(defun c-string->lisp-string (string &optional limit)
(declare (ignore limit))
(cast string c-string))
(defun (setf c-string->lisp-string) (new-string alien &optional limit)
(declare (string new-string))
(let* ((upper-bound (or limit (1+ (length new-string))))
(last-elt (min (1- upper-bound) (length new-string))))
(loop for i upfrom 0 below last-elt
for char across new-string
do (setf (deref alien i) (char-code char)))
(setf (deref alien last-elt) 0)
(subseq new-string 0 last-elt)))
(defgeneric accessors-for (struct-name element path))
(defmethod accessors-for (struct-name (root structured-type) path)
nil)
(defmethod accessors-for (struct-name (root value-slot) path)
(let ((rpath (reverse path))
(accessor-name (format nil "~A-~A"
(symbol-name struct-name)
(symbol-name (name root)))))
(labels ((accessor (root rpath)
(apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root))))))
`((declaim (inline ,(intern accessor-name)
(setf ,(intern accessor-name))))
(defun ,(intern accessor-name) (struct)
(declare (cl:type (alien (* ,struct-name)) struct)
(optimize (speed 3)))
(,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel))
:getter)
,(accessor root rpath) ,(size root)))
(defun (setf ,(intern accessor-name)) (new-val struct)
(declare (cl:type (alien (* ,struct-name)) struct)
(cl:type ,(lisp-type-for (type root) (size root)) new-val)
(optimize (speed 3)))
,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root)
(find-package :sb-grovel))
:setter))
(modified-accessor (if accessor-modifier
`(,accessor-modifier ,(accessor root rpath) ,(size root))
(accessor root rpath))))
`(setf ,modified-accessor new-val)))
(defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name))
,(offset root))))))
(defmethod accessors-for (struct (root padding) path)
nil)
(defgeneric generate-struct-definition (struct-name root path))
(defmethod generate-struct-definition (struct-name (root structured-type) path)
(let ((naccessors (accessors-for struct-name root path))
(nslots nil))
(dolist (child (children root))
(multiple-value-bind (slots accessors)
(generate-struct-definition struct-name child (cons root path))
(setf nslots (nconc nslots slots))
(setf naccessors (nconc naccessors accessors))))
(values `((,(name root) (,(type-of root) ,(name root) ,@nslots)))
naccessors)))
(defmethod generate-struct-definition (struct-name (root value-slot) path)
(values `((,(name root) ,(alien-type-for (type root) (size root))))
(accessors-for struct-name root path)))
(defmacro define-c-struct (name size &rest elements)
(multiple-value-bind (struct-elements accessors)
(let* ((root (make-instance 'struct :name name :children nil :offset 0)))
(loop for e in (sort elements #'< :key #'fourth)
do (insert-element root (apply 'mk-val e))
finally (return root))
(setf (children root)
(nconc (children root)
(list
(mk-padding (max 0 (- size
(size root)))
(size root)))))
(generate-struct-definition name root nil))
`(progn
(sb-alien:define-alien-type ,@(first struct-elements))
,@accessors
(defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body)
(labels ((field-name (x)
(intern (concatenate 'string
(symbol-name ',name) "-"
(symbol-name x))
,(symbol-package name))))
`(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name)))))
(unwind-protect
(progn
(progn ,@(mapcar (lambda (pair)
`(setf (,(field-name (first pair)) ,var) ,(second pair)))
field-values))
,@body)
(funcall ',',(intern (format nil "FREE-~A" name)) ,var)))))
(defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size)
(defun ,(intern (format nil "ALLOCATE-~A" name)) ()
(let* ((o (sb-alien:make-alien ,name))
(c-o (cast o (* (unsigned 8)))))
;; we have to initialize the object to all-0 before we can
;; expect to make sensible use of it - the object returned
;; by make-alien is initialized to all-D0 bytes.
;; FIXME: This should be fixed in sb-alien, where better
;; optimizations might be possible.
(loop for i from 0 below ,size
do (setf (deref c-o i) 0))
o))
(defun ,(intern (format nil "FREE-~A" name)) (o)
(sb-alien:free-alien o)))))
(defun foreign-nullp (c)
"C is a pointer to 0?"
(null-alien c))