1 (in-package :sb-grovel
)
3 ;;;; The macros defined here are called from #:Gconstants.lisp, which was
4 ;;;; generated from constants.lisp by the C compiler as driven by that
5 ;;;; wacky def-to-lisp thing.
7 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
8 ;;; C-CALL:C-STRING) (BUF (* T)) )
10 ;;; I can't help thinking this was originally going to do something a
12 (defmacro define-foreign-routine
13 (&whole it
(c-name lisp-name
) return-type
&rest args
)
14 (declare (ignorable c-name lisp-name return-type args
))
15 `(define-alien-routine ,@(cdr it
)))
21 #| C structs need
: the with-... interface.
26 XXX
: :distrust-length t fields are dangerous. they should only be at
27 the end of the structure
(they mess up offset
/size calculations
)
30 (defun reintern (symbol &optional
(package *package
*))
32 (intern (symbol-name symbol
) package
)
35 (defparameter alien-type-table
(make-hash-table :test
'eql
))
36 (defparameter lisp-type-table
(make-hash-table :test
'eql
))
38 (macrolet ((define-alien-types ((type size
) &rest defns
)
40 ,@(loop for defn in defns
41 collect
(destructuring-bind (expected-type c-type lisp-type
) defn
43 (setf (gethash ',expected-type alien-type-table
)
45 (declare (ignorable type size
))
47 (setf (gethash ',expected-type lisp-type-table
)
49 (declare (ignorable type size
))
51 (define-alien-types (type size
)
52 (integer (or (gethash size
(symbol-value (intern "*INTEGER-SIZES*")))
53 `(integer ,(* 8 size
)))
54 `(unsigned-byte ,(* 8 size
)))
55 (unsigned `(unsigned ,(* 8 size
))
56 `(unsigned-byte ,(* 8 size
)))
57 (signed `(signed ,(* 8 size
))
58 `(signed-byte ,(* 8 size
)))
59 (c-string `(array char
,size
) 'cl
:simple-string
)
60 (c-string-pointer 'c-string
'cl
:simple-string
)
61 ;; TODO: multi-dimensional arrays, if they are ever needed.
62 (array (destructuring-bind (array-tag elt-type
&optional array-size
) type
63 (declare (ignore array-tag
))
64 ;; XXX: use of EVAL. alien-size is a macro,
65 ;; unfortunately; and it will only accept unquoted type
67 `(sb-alien:array
,elt-type
,(or array-size
68 (/ size
(eval `(sb-alien:alien-size
,elt-type
:bytes
))))))
71 (defun retrieve-type-for (type size table
)
72 (multiple-value-bind (type-fn found
)
73 (gethash (reintern (typecase type
76 (find-package '#:sb-grovel
))
80 (funcall (the function type-fn
) type size
)
84 (defun alien-type-for (type size
)
85 (reintern (retrieve-type-for type size alien-type-table
)))
87 (defun lisp-type-for (type size
)
88 (multiple-value-bind (val found
)
89 (retrieve-type-for type size lisp-type-table
)
95 (defun mk-padding (len offset
)
96 (make-instance 'padding
97 :type
`(array char
,len
)
100 :name
(intern (format nil
"PADDING-~D-~D" len offset
))))
101 (defun mk-struct (offset &rest children
)
102 (make-instance 'struct
:name
(gentemp "STRUCT")
103 :children
(remove nil children
)
105 (defun mk-union (offset &rest children
)
106 (make-instance 'union
:name
(gentemp "UNION")
107 :children
(remove nil children
)
109 (defun mk-val (name type h-type offset size
)
110 (declare (ignore h-type
))
111 (make-instance 'value-slot
:name name
116 ;;; struct tree classes
119 ((offset :initarg
:offset
:reader offset
)
120 (name :initarg
:name
:reader name
)))
122 (defclass structured-type
(slot)
123 ((children :initarg
:children
:accessor children
)))
125 (defclass union
(structured-type)
128 (defclass struct
(structured-type)
131 (defclass value-slot
(slot)
132 ((size :initarg
:size
:reader size
)
133 (type :initarg
:type
:reader type
)))
135 (defclass padding
(value-slot)
138 (defmethod print-object ((o value-slot
) s
)
139 (print-unreadable-object (o s
:type t
)
140 (format s
"~S ~A+~A=~A" (name o
) (offset o
) (size o
) (slot-end o
))))
142 (defmethod print-object ((o structured-type
) s
)
143 (print-unreadable-object (o s
:type t
)
144 (format s
"~S ~A" (name o
) (children o
))))
146 (defmethod size ((slot structured-type
))
147 (let ((min-offset (offset slot
)))
148 (if (null (children slot
))
150 (reduce #'max
(mapcar (lambda (child)
151 (+ (- (offset child
) min-offset
) (size child
)))
155 (defgeneric slot-end
(slot))
156 (defmethod slot-end ((slot slot
))
157 (+ (offset slot
) (size slot
)))
159 (defun overlap-p (elt1 elt2
)
160 (unless (or (zerop (size elt1
))
163 (and (<= (offset elt1
)
167 (and (<= (offset elt2
)
172 (defgeneric find-overlaps
(root new-element
))
173 (defmethod find-overlaps ((root structured-type
) new-element
)
174 (when (overlap-p root new-element
)
175 (let ((overlapping-elts (loop for child in
(children root
)
176 for overlap
= (find-overlaps child new-element
)
179 (cons root overlapping-elts
))))
181 (defmethod find-overlaps ((root value-slot
) new-element
)
182 (when (overlap-p root new-element
)
185 (defgeneric pad-to-offset-of
(to-pad parent
))
186 (macrolet ((skel (end-form)
187 `(let* ((end ,end-form
)
188 (len (abs (- (offset to-pad
) end
))))
190 ((= end
(offset to-pad
)) ; we are at the right offset.
192 (t ; we have to pad between the
193 ; old slot's end and the new
195 (mk-padding len end
))))))
197 (defmethod pad-to-offset-of (to-pad (parent struct
))
198 (skel (if (null (children parent
))
200 (+ (size parent
) (offset parent
)))))
201 (defmethod pad-to-offset-of (to-pad (parent union
))
202 (skel (if (null (children parent
))
206 (defgeneric replace-by-union
(in-st element new-element
))
207 (defmethod replace-by-union ((in-st struct
) elt new-elt
)
208 (setf (children in-st
) (remove elt
(children in-st
)))
209 (let ((padding (pad-to-offset-of new-elt in-st
)))
210 (setf (children in-st
)
211 (nconc (children in-st
)
212 (list (mk-union (offset elt
)
215 (mk-struct (offset elt
)
220 (defmethod replace-by-union ((in-st union
) elt new-elt
)
221 (let ((padding (pad-to-offset-of new-elt in-st
)))
222 (setf (children in-st
)
223 (nconc (children in-st
)
225 (mk-struct (offset in-st
)
230 (defgeneric insert-element
(root new-elt
))
231 (defmethod insert-element ((root struct
) (new-elt slot
))
232 (let ((overlaps (find-overlaps root new-elt
)))
234 (overlaps (let ((last-structure (first (last overlaps
2)))
235 (last-val (first (last overlaps
))))
236 (replace-by-union last-structure last-val new-elt
)
239 (let ((padding (pad-to-offset-of new-elt root
)))
240 (setf (children root
)
241 (nconc (children root
)
242 (when padding
(list padding
))
246 (defun sane-slot (alien-var &rest slots
)
247 "Emulates the SB-ALIEN:SLOT interface, with useful argument order for
248 deeply nested structures."
249 (labels ((rewriter (slots)
252 `(sb-alien:slot
,(rewriter (rest slots
))
256 (defgeneric accessor-modifier-for
(element-type accessor-type
))
258 (defmethod accessor-modifier-for (element-type (accessor-type (eql :getter
)))
260 (defmethod accessor-modifier-for (element-type (accessor-type (eql :setter
)))
263 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING
))
264 (accessor-type (eql :getter
)))
267 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
268 (accessor-type (eql :setter)))
271 ;; The "[1]" in the name c-string-reader[1] refers to the CLHS
272 ;; glossary entry definitions for "reader
".
273 (defun c-string-reader[1] (place &optional limit)
274 (declare (ignore limit))
275 `(cast ,place c-string))
277 (defun c-string-writer (string alien &optional limit)
278 (sb-int:with-unique-names
279 (stringvar upper-bound last-elt octets alien-ptr index)
280 `(let* ((,stringvar ,string)
281 (,upper-bound (or ,limit (1+ (length ,stringvar))))
282 (,last-elt (min (1- ,upper-bound) (length ,stringvar)))
283 (,octets (sb-ext:string-to-octets ,stringvar :end ,last-elt
285 (,alien-ptr (cast ,alien (* unsigned-char))))
286 (declare (cl:type (simple-array (unsigned-byte 8) (*)) ,octets))
287 (declare (cl:type sb-int:index ,last-elt))
288 (dotimes (,index ,last-elt)
289 (setf (deref ,alien-ptr ,index) (aref ,octets ,index)))
290 (subseq ,stringvar 0 ,last-elt))))
292 (defgeneric accessors-for (struct-name element path))
293 (defmethod accessors-for (struct-name (root structured-type) path)
297 (defmethod accessors-for (struct-name (root value-slot) path)
298 (let* ((rpath (reverse path))
299 (accessor-name (intern
301 (symbol-name struct-name)
302 (symbol-name (name root)))))
303 (offset-constant-name (intern
304 (format nil "OFFSET-OF-~A
" accessor-name)))
305 (var (gensym "VAR-
"))
306 (place (apply #'sane-slot 'struct
307 (mapcar 'name (append (rest rpath) (list root)))))
308 (reader (let ((reader (accessor-modifier-for
309 (reintern (type root)
310 (find-package :sb-grovel))
313 (funcall reader place (size root))
315 (writer (let ((writer (accessor-modifier-for
316 (reintern (type root)
317 (find-package :sb-grovel))
320 (funcall writer var place (size root))
321 `(setf ,place ,var)))))
322 `((declaim (inline ,accessor-name (setf ,accessor-name)))
323 (defun ,accessor-name (struct)
324 (declare (cl:type (alien (* ,struct-name)) struct)
325 (optimize (speed 3)))
327 (defun (setf ,accessor-name) (,var struct)
328 (declare (cl:type (alien (* ,struct-name)) struct)
329 (cl:type ,(lisp-type-for (type root) (size root)) ,var)
330 (optimize (speed 3)))
332 (defconstant ,offset-constant-name
337 (defmethod accessors-for (struct (root padding) path)
340 (defgeneric generate-struct-definition (struct-name root path))
341 (defmethod generate-struct-definition (struct-name (root structured-type) path)
342 (let ((naccessors (accessors-for struct-name root path))
344 (dolist (child (children root))
345 (multiple-value-bind (slots accessors)
346 (generate-struct-definition struct-name child (cons root path))
347 (setf nslots (nconc nslots slots))
348 (setf naccessors (nconc naccessors accessors))))
349 (values `((,(name root) (,(type-of root) ,(name root) ,@nslots)))
352 (defmethod generate-struct-definition (struct-name (root value-slot) path)
353 (values `((,(name root) ,(alien-type-for (type root) (size root))))
354 (accessors-for struct-name root path)))
356 (defmacro define-c-struct (name size &rest elements)
357 (multiple-value-bind (struct-elements accessors)
358 (let* ((root (make-instance 'struct :name name :children nil :offset 0)))
359 (loop for e in (sort elements #'< :key #'fourth)
360 do (insert-element root (apply 'mk-val e))
361 finally (return root))
362 (setf (children root)
363 (nconc (children root)
365 (mk-padding (max 0 (- size
368 (generate-struct-definition name root nil))
369 (sb-int:with-unique-names (var field-values body field-name pair
370 object c-object index)
371 (let ((with (intern (format nil "WITH-~A
" name)))
372 (allocate (intern (format nil "ALLOCATE-~A
" name)))
373 (free (intern (format nil "FREE-~A
" name)))
374 (size-of (intern (format nil "SIZE-OF-~A
" name))))
376 (sb-alien:define-alien-type ,@(first struct-elements))
378 (defmacro ,with (,var (&rest ,field-values) &body ,body)
379 (labels ((,field-name (,var)
381 (format nil ,(format nil "~A-~~A
" (symbol-name name))
383 ,(symbol-package name))))
384 `(sb-alien:with-alien ((,,var (* ,',name) ,'(,allocate)))
389 `((,(,field-name (first ,pair)) ,,var)
394 (defconstant ,size-of ,size)
396 (let* ((,object (sb-alien:make-alien ,name))
397 (,c-object (cast ,object (* (unsigned 8)))))
398 ;; we have to initialize the object to all-0 before we can
399 ;; expect to make sensible use of it - the object returned
400 ;; by make-alien is initialized to all-D0 bytes.
402 ;; FIXME: This should be fixed in sb-alien, where better
403 ;; optimizations might be possible.
404 (dotimes (,index ,size)
405 (setf (deref ,c-object ,index) 0))
407 (defun ,free (,object)
408 (sb-alien:free-alien ,object)))))))
410 ;; FIXME: Nothing in SBCL uses this, but kept it around in case there
411 ;; are third-party sb-grovel clients. It should go away eventually,
412 ;; on the principle that sb-grovel should only have to be loaded in
413 ;; order to do an actual groveling run.
414 (defun foreign-nullp (c)
415 "Deprecated. Use SB-ALIEN
:NULL-ALIEN instead.
"