1.0.14.12: export SB-POSIX:MKSTEMP, add SB-POSIX:MKTEMP and SB-POSIX:MKDTEMP
[sbcl.git] / contrib / sb-grovel / foreign-glue.lisp
1 (in-package :sb-grovel)
2
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.
6
7 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
8 ;;; C-CALL:C-STRING) (BUF (* T)) )
9
10 ;;; I can't help thinking this was originally going to do something a
11 ;;; lot more complex
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)))
16
17
18
19 ;;; strctures
20
21 #| C structs need: the with-... interface.
22 |#
23
24 ;;; global XXXs:
25 #|
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)
28 |#
29
30 (defun reintern (symbol &optional (package *package*))
31   (if (symbolp symbol)
32       (intern (symbol-name symbol) package)
33       symbol))
34
35 (defparameter alien-type-table (make-hash-table :test 'eql))
36 (defparameter lisp-type-table (make-hash-table :test 'eql))
37
38 (macrolet ((define-alien-types ((type size) &rest defns)
39                `(progn
40                   ,@(loop for defn in defns
41                           collect (destructuring-bind (expected-type c-type lisp-type) defn
42                                     `(progn
43                                        (setf (gethash ',expected-type alien-type-table)
44                                              (lambda (,type ,size)
45                                                (declare (ignorable type size))
46                                                ,c-type))
47                                        (setf (gethash ',expected-type lisp-type-table)
48                                              (lambda (,type ,size)
49                                                (declare (ignorable type size))
50                                                ,lisp-type))))))))
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
66                ;; forms.
67                `(sb-alien:array ,elt-type ,(or array-size
68                                                (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
69              t)))
70
71 (defun retrieve-type-for (type size table)
72   (multiple-value-bind (type-fn found)
73       (gethash (reintern (typecase type
74                            (list (first type))
75                            (t    type))
76                          (find-package '#:sb-grovel))
77                table)
78     (values
79      (if found
80          (funcall (the function type-fn) type size)
81          type)
82      found)))
83
84 (defun alien-type-for (type size)
85   (reintern (retrieve-type-for type size alien-type-table)))
86
87 (defun lisp-type-for (type size)
88   (multiple-value-bind (val found)
89       (retrieve-type-for type size lisp-type-table)
90     (if found
91         val
92         t)))
93
94
95 (defun mk-padding (len offset)
96   (make-instance 'padding
97                  :type `(array char ,len)
98                  :offset offset
99                  :size len
100                  :name (gentemp "PADDING")))
101 (defun mk-struct (offset &rest children)
102   (make-instance 'struct :name (gentemp "STRUCT")
103                  :children (remove nil children)
104                  :offset offset))
105 (defun mk-union (offset &rest children)
106   (make-instance 'union :name (gentemp "UNION")
107                  :children (remove nil children)
108                  :offset offset))
109 (defun mk-val (name type h-type offset size)
110   (declare (ignore h-type))
111   (make-instance 'value-slot :name name
112                  :size size
113                  :offset offset
114                  :type type))
115
116 ;;; struct tree classes
117
118 (defclass slot ()
119   ((offset :initarg :offset :reader offset)
120    (name :initarg :name :reader name)))
121
122 (defclass structured-type (slot)
123   ((children :initarg :children :accessor children)))
124
125 (defclass union (structured-type)
126   ())
127
128 (defclass struct (structured-type)
129   ())
130
131 (defclass value-slot (slot)
132   ((size :initarg :size :reader size)
133    (type :initarg :type :reader type)))
134
135 (defclass padding (value-slot)
136   ())
137
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))))
141
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))))
145
146 (defmethod size ((slot structured-type))
147   (let ((min-offset (offset slot)))
148     (if (null (children slot))
149         0
150         (reduce #'max (mapcar (lambda (child)
151                                 (+ (- (offset child) min-offset) (size child)))
152                               (children slot))
153                 :initial-value 0))))
154
155 (defgeneric slot-end (slot))
156 (defmethod slot-end ((slot slot))
157   (+ (offset slot) (size slot)))
158
159 (defun overlap-p (elt1 elt2)
160   (unless (or (zerop (size elt1))
161               (zerop (size elt2)))
162     (or
163      (and (<= (offset elt1)
164               (offset elt2))
165           (< (offset elt2)
166              (slot-end elt1)))
167      (and (<= (offset elt2)
168               (offset elt1))
169           (< (offset elt1)
170              (slot-end elt2))))))
171
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)
177                                   when overlap
178                                      return overlap)))
179       (cons root overlapping-elts))))
180
181 (defmethod find-overlaps ((root value-slot) new-element)
182   (when (overlap-p root new-element)
183     (list root)))
184
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))))
189                 (cond
190                   ((= end (offset to-pad)) ; we are at the right offset.
191                    nil)
192                   (t                    ; we have to pad between the
193                                         ; old slot's end and the new
194                                         ; slot's offset
195                    (mk-padding len end))))))
196
197   (defmethod pad-to-offset-of (to-pad (parent struct))
198     (skel (if (null (children parent))
199               0
200               (+ (size parent) (offset parent)))))
201   (defmethod pad-to-offset-of (to-pad (parent union))
202     (skel (if (null (children parent))
203               (offset to-pad)
204               (offset parent)))))
205
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)
213                                  elt
214                                  (if padding
215                                      (mk-struct (offset elt)
216                                                 padding
217                                                 new-elt)
218                                      new-elt)))))))
219
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)
224                  (list (if padding
225                            (mk-struct (offset in-st)
226                                       padding
227                                       new-elt)
228                            new-elt))))))
229
230 (defgeneric insert-element (root new-elt))
231 (defmethod insert-element ((root struct) (new-elt slot))
232   (let ((overlaps (find-overlaps root new-elt)))
233     (cond
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)
237                   root))
238       (t
239        (let ((padding (pad-to-offset-of new-elt root)))
240          (setf (children root)
241                (nconc (children root)
242                       (when padding (list padding))
243                       (list new-elt)))))))
244   root)
245
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)
250              (if (null slots)
251                  alien-var
252                  `(sb-alien:slot ,(rewriter (rest slots))
253                                  ',(first slots)))))
254     (rewriter slots)))
255
256 (defgeneric accessor-modifier-for (element-type accessor-type))
257
258 (defmacro identity-1 (thing &rest ignored)
259   (declare (ignore ignored))
260   thing)
261 (defun (setf identity-1) (new-thing place &rest ignored)
262   (declare (ignore ignored))
263   (setf place new-thing))
264
265 (defmethod accessor-modifier-for (element-type (accessor-type (eql :getter)))
266   'identity-1)
267 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
268                                   (accessor-type (eql :getter)))
269   'c-string->lisp-string)
270 (defmethod accessor-modifier-for (element-type (accessor-type (eql :setter)))
271   nil)
272 (defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
273                                   (accessor-type (eql :setter)))
274   'c-string->lisp-string)
275
276 (defun c-string->lisp-string (string &optional limit)
277   (declare (ignore limit))
278   (cast string c-string))
279
280 (defun (setf c-string->lisp-string) (new-string alien &optional limit)
281   (declare (string new-string))
282   (let* ((upper-bound (or limit (1+ (length new-string))))
283          (last-elt (min (1- upper-bound) (length new-string)))
284          (octets (sb-ext:string-to-octets new-string :end last-elt
285                                           :null-terminate t))
286          (alien-pointer (cast alien (* unsigned-char))))
287     (declare (cl:type (simple-array (unsigned-byte 8) (*)) octets))
288     (declare (cl:type sb-int:index last-elt))
289     (loop for i from 0 to last-elt
290           do (setf (deref alien-pointer i) (aref octets i)))
291     (subseq new-string 0 last-elt)))
292
293 (defgeneric accessors-for (struct-name element path))
294 (defmethod accessors-for (struct-name (root structured-type) path)
295   nil)
296
297
298 (defmethod accessors-for (struct-name (root value-slot) path)
299   (let ((rpath (reverse path))
300         (accessor-name (format nil "~A-~A"
301                                (symbol-name struct-name)
302                                (symbol-name (name root)))))
303     (labels ((accessor (root rpath)
304                (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root))))))
305       `((declaim (inline ,(intern accessor-name)
306                          (setf ,(intern accessor-name))))
307         (defun ,(intern accessor-name) (struct)
308           (declare (cl:type (alien (* ,struct-name)) struct)
309                    (optimize (speed 3)))
310           (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel))
311                                    :getter)
312             ,(accessor root rpath) ,(size root)))
313         (defun (setf ,(intern accessor-name)) (new-val struct)
314           (declare (cl:type (alien (* ,struct-name)) struct)
315                    (cl:type ,(lisp-type-for (type root) (size root)) new-val)
316                    (optimize (speed 3)))
317           ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root)
318                                                                       (find-package :sb-grovel))
319                                                             :setter))
320                   (modified-accessor (if accessor-modifier
321                                          `(,accessor-modifier ,(accessor root rpath) ,(size root))
322                                          (accessor root rpath))))
323
324              `(setf ,modified-accessor new-val)))
325         (defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name))
326           ,(offset root))))))
327
328
329
330 (defmethod accessors-for (struct (root padding) path)
331   nil)
332
333 (defgeneric generate-struct-definition (struct-name root path))
334 (defmethod generate-struct-definition (struct-name (root structured-type) path)
335   (let ((naccessors (accessors-for struct-name root path))
336         (nslots nil))
337     (dolist (child (children root))
338       (multiple-value-bind (slots accessors)
339           (generate-struct-definition struct-name child (cons root path))
340         (setf nslots (nconc nslots slots))
341         (setf naccessors (nconc naccessors accessors))))
342     (values `((,(name root) (,(type-of root) ,(name root) ,@nslots)))
343             naccessors)))
344
345 (defmethod generate-struct-definition (struct-name (root value-slot) path)
346   (values `((,(name root) ,(alien-type-for (type root) (size root))))
347           (accessors-for struct-name root path)))
348
349 (defmacro define-c-struct (name size &rest elements)
350   (multiple-value-bind (struct-elements accessors)
351       (let* ((root (make-instance 'struct :name name :children nil :offset 0)))
352         (loop for e in (sort elements #'< :key #'fourth)
353               do (insert-element root (apply 'mk-val e))
354               finally (return root))
355         (setf (children root)
356               (nconc (children root)
357                      (list
358                       (mk-padding (max 0 (- size
359                                             (size root)))
360                                   (size root)))))
361         (generate-struct-definition name root nil))
362     `(progn
363        (sb-alien:define-alien-type ,@(first struct-elements))
364        ,@accessors
365        (defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body)
366          (labels ((field-name (x)
367                     (intern (concatenate 'string
368                                          (symbol-name ',name) "-"
369                                          (symbol-name x))
370                             ,(symbol-package name))))
371            `(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name)))))
372               (unwind-protect
373                   (progn
374                     (progn ,@(mapcar (lambda (pair)
375                                        `(setf (,(field-name (first pair)) ,var) ,(second pair)))
376                                      field-values))
377                     ,@body)
378                 (funcall ',',(intern (format nil "FREE-~A" name)) ,var)))))
379        (defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size)
380        (defun ,(intern (format nil "ALLOCATE-~A" name)) ()
381          (let* ((o (sb-alien:make-alien ,name))
382                 (c-o (cast o (* (unsigned 8)))))
383            ;; we have to initialize the object to all-0 before we can
384            ;; expect to make sensible use of it - the object returned
385            ;; by make-alien is initialized to all-D0 bytes.
386
387            ;; FIXME: This should be fixed in sb-alien, where better
388            ;; optimizations might be possible.
389            (loop for i from 0 below ,size
390                  do (setf (deref c-o i) 0))
391            o))
392        (defun ,(intern (format nil "FREE-~A" name)) (o)
393          (sb-alien:free-alien o)))))
394
395 (defun foreign-nullp (c)
396   "C is a pointer to 0?"
397   (null-alien c))