Introduction
Introduction Statistics Contact Development Disclaimer Help
tgrovel.lisp - clic - Clic is an command line interactive client for gopher wri…
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
Log
Files
Refs
Tags
LICENSE
---
tgrovel.lisp (36543B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; grovel.lisp --- The CFFI Groveller.
4 ;;;
5 ;;; Copyright (C) 2005-2006, Dan Knap <[email protected]>
6 ;;; Copyright (C) 2005-2006, Emily Backes <[email protected]>
7 ;;; Copyright (C) 2007, Stelian Ionescu <[email protected]>
8 ;;; Copyright (C) 2007, Luis Oliveira <[email protected]>
9 ;;;
10 ;;; Permission is hereby granted, free of charge, to any person
11 ;;; obtaining a copy of this software and associated documentation
12 ;;; files (the "Software"), to deal in the Software without
13 ;;; restriction, including without limitation the rights to use, copy,
14 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
15 ;;; of the Software, and to permit persons to whom the Software is
16 ;;; furnished to do so, subject to the following conditions:
17 ;;;
18 ;;; The above copyright notice and this permission notice shall be
19 ;;; included in all copies or substantial portions of the Software.
20 ;;;
21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
24 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
25 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
26 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
27 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
28 ;;; DEALINGS IN THE SOFTWARE.
29 ;;;
30
31 (in-package #:cffi-grovel)
32
33 ;;;# Error Conditions
34
35 (define-condition grovel-error (simple-error) ())
36
37 (defun grovel-error (format-control &rest format-arguments)
38 (error 'grovel-error
39 :format-control format-control
40 :format-arguments format-arguments))
41
42 ;;; This warning is signalled when cffi-grovel can't find some macro.
43 ;;; Signalled by CONSTANT or CONSTANTENUM.
44 (define-condition missing-definition (warning)
45 ((%name :initarg :name :reader name-of))
46 (:report (lambda (condition stream)
47 (format stream "No definition for ~A"
48 (name-of condition)))))
49
50 ;;;# Grovelling
51
52 ;;; The header of the intermediate C file.
53 (defparameter *header*
54 "/*
55 * This file has been automatically generated by cffi-grovel.
56 * Do not edit it by hand.
57 */
58
59 ")
60
61 ;;; C code generated by cffi-grovel is inserted between the contents
62 ;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.
63
64 (defparameter *prologue*
65 "
66 #include <grovel/common.h>
67
68 int main(int argc, char**argv) {
69 int autotype_tmp;
70 FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
71 fprintf(output, \";;;; This file has been automatically generated by \"
72 \"cffi-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
73 ")
74
75 (defparameter *postscript*
76 "
77 if (output != stdout)
78 fclose(output);
79 return 0;
80 }
81 ")
82
83 (defun unescape-for-c (text)
84 (with-output-to-string (result)
85 (loop for i below (length text)
86 for char = (char text i) do
87 (cond ((eql char #\") (princ "\\\"" result))
88 ((eql char #\newline) (princ "\\n" result))
89 (t (princ char result))))))
90
91 (defun c-format (out fmt &rest args)
92 (let ((text (unescape-for-c (format nil "~?" fmt args))))
93 (format out "~& fputs(\"~A\", output);~%" text)))
94
95 (defun c-printf (out fmt &rest args)
96 (flet ((item (item)
97 (format out "~A" (unescape-for-c (format nil item)))))
98 (format out "~& fprintf(output, \"")
99 (item fmt)
100 (format out "\"")
101 (loop for arg in args do
102 (format out ", ")
103 (item arg))
104 (format out ");~%")))
105
106 (defun c-print-integer-constant (out arg &optional foreign-type)
107 (let ((foreign-type (or foreign-type :int)))
108 (c-format out "#.(cffi-grovel::convert-intmax-constant ")
109 (format out "~& fprintf(output, \"%\"PRIiMAX, (intmax_t)~A);~%"
110 arg)
111 (c-format out " ")
112 (c-write out `(quote ,foreign-type))
113 (c-format out ")")))
114
115 ;;; TODO: handle packages in a better way. One way is to process each
116 ;;; grovel form as it is read (like we already do for wrapper
117 ;;; forms). This way in can expect *PACKAGE* to have sane values.
118 ;;; This would require that "header forms" come before any other
119 ;;; forms.
120 (defun c-print-symbol (out symbol &optional no-package)
121 (c-format out
122 (let ((package (symbol-package symbol)))
123 (cond
124 ((eq (find-package '#:keyword) package) ":~(~A~)")
125 (no-package "~(~A~)")
126 ((eq (find-package '#:cl) package) "cl:~(~A~)")
127 (t "~(~A~)")))
128 symbol))
129
130 (defun c-write (out form &optional no-package)
131 (cond
132 ((and (listp form)
133 (eq 'quote (car form)))
134 (c-format out "'")
135 (c-write out (cadr form) no-package))
136 ((listp form)
137 (c-format out "(")
138 (loop for subform in form
139 for first-p = t then nil
140 unless first-p do (c-format out " ")
141 do (c-write out subform no-package))
142 (c-format out ")"))
143 ((symbolp form)
144 (c-print-symbol out form no-package))))
145
146 ;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
147 ;;; later, if necessary.
148 (defvar *auto-export* nil)
149
150 (defun c-export (out symbol)
151 (when (and *auto-export* (not (keywordp symbol)))
152 (c-format out "(cl:export '")
153 (c-print-symbol out symbol t)
154 (c-format out ")~%")))
155
156 (defun c-section-header (out section-type section-symbol)
157 (format out "~% /* ~A section for ~S */~%"
158 section-type
159 section-symbol))
160
161 (defun remove-suffix (string suffix)
162 (let ((suffix-start (- (length string) (length suffix))))
163 (if (and (> suffix-start 0)
164 (string= string suffix :start1 suffix-start))
165 (subseq string 0 suffix-start)
166 string)))
167
168 (defgeneric %process-grovel-form (name out arguments)
169 (:method (name out arguments)
170 (declare (ignore out arguments))
171 (grovel-error "Unknown Grovel syntax: ~S" name)))
172
173 (defun process-grovel-form (out form)
174 (%process-grovel-form (form-kind form) out (cdr form)))
175
176 (defun form-kind (form)
177 ;; Using INTERN here instead of FIND-SYMBOL will result in less
178 ;; cryptic error messages when an undefined grovel/wrapper form is
179 ;; found.
180 (intern (symbol-name (car form)) '#:cffi-grovel))
181
182 (defvar *header-forms* '(c include define flag typedef))
183
184 (defun header-form-p (form)
185 (member (form-kind form) *header-forms*))
186
187 (defun generate-c-file (input-file output-defaults)
188 (nest
189 (with-standard-io-syntax)
190 (let ((c-file (make-c-file-name output-defaults "__grovel"))
191 (*print-readably* nil)
192 (*print-escape* t)))
193 (with-open-file (out c-file :direction :output :if-exists :supersede))
194 (with-open-file (in input-file :direction :input))
195 (flet ((read-forms (s)
196 (do ((forms ())
197 (form (read s nil nil) (read s nil nil)))
198 ((null form) (nreverse forms))
199 (labels
200 ((process-form (f)
201 (case (form-kind f)
202 (flag (warn "Groveler clause FLAG is deprecated, …
203 (case (form-kind f)
204 (in-package
205 (setf *package* (find-package (second f)))
206 (push f forms))
207 (progn
208 ;; flatten progn forms
209 (mapc #'process-form (rest f)))
210 (t (push f forms)))))
211 (process-form form))))))
212 (let* ((forms (read-forms in))
213 (header-forms (remove-if-not #'header-form-p forms))
214 (body-forms (remove-if #'header-form-p forms)))
215 (write-string *header* out)
216 (dolist (form header-forms)
217 (process-grovel-form out form))
218 (write-string *prologue* out)
219 (dolist (form body-forms)
220 (process-grovel-form out form))
221 (write-string *postscript* out)
222 c-file)))
223
224 (defun tmp-lisp-file-name (defaults)
225 (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp")
226 :type "lisp" :defaults defaults))
227
228
229
230 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
231 ;;; *the extent of a given grovel file.
232 (defun process-grovel-file (input-file &optional (output-defaults input-…
233 (with-standard-io-syntax
234 (let* ((c-file (generate-c-file input-file output-defaults))
235 (o-file (make-o-file-name c-file))
236 (exe-file (make-exe-file-name c-file))
237 (lisp-file (tmp-lisp-file-name c-file))
238 (inputs (list (cc-include-grovel-argument) c-file)))
239 (handler-case
240 (progn
241 ;; at least MKCL wants to separate compile and link
242 (cc-compile o-file inputs)
243 (link-executable exe-file (list o-file)))
244 (error (e)
245 (grovel-error "~a" e)))
246 (invoke exe-file lisp-file)
247 lisp-file)))
248
249 ;;; OUT is lexically bound to the output stream within BODY.
250 (defmacro define-grovel-syntax (name lambda-list &body body)
251 (with-unique-names (name-var args)
252 `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args)
253 (declare (ignorable out))
254 (destructuring-bind ,lambda-list ,args
255 ,@body))))
256
257 (define-grovel-syntax c (body)
258 (format out "~%~A~%" body))
259
260 (define-grovel-syntax include (&rest includes)
261 (format out "~{#include <~A>~%~}" includes))
262
263 (define-grovel-syntax define (name &optional value)
264 (format out "#define ~A~@[ ~A~]~%" name value))
265
266 (define-grovel-syntax typedef (base-type new-type)
267 (format out "typedef ~A ~A;~%" base-type new-type))
268
269 ;;; Is this really needed?
270 (define-grovel-syntax ffi-typedef (new-type base-type)
271 (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type))
272
273 (define-grovel-syntax flag (&rest flags)
274 (appendf *cc-flags* (parse-command-flags-list flags)))
275
276 (define-grovel-syntax cc-flags (&rest flags)
277 (appendf *cc-flags* (parse-command-flags-list flags)))
278
279 (define-grovel-syntax pkg-config-cflags (pkg &key optional)
280 (let ((output-stream (make-string-output-stream))
281 (program+args (list "pkg-config" pkg "--cflags")))
282 (format *debug-io* "~&;~{ ~a~}~%" program+args)
283 (handler-case
284 (progn
285 (run-program program+args
286 :output (make-broadcast-stream output-stream *deb…
287 :error-output output-stream)
288 (appendf *cc-flags*
289 (parse-command-flags (get-output-stream-string output…
290 (error (e)
291 (let ((message (format nil "~a~&~%~a~&"
292 e (get-output-stream-string output-stream…
293 (cond (optional
294 (format *debug-io* "~&; ERROR: ~a" message)
295 (format *debug-io* "~&~%; Attempting to continue anyway…
296 (t
297 (grovel-error "~a" message))))))))
298
299 ;;; This form also has some "read time" effects. See GENERATE-C-FILE.
300 (define-grovel-syntax in-package (name)
301 (c-format out "(cl:in-package #:~A)~%~%" name))
302
303 (define-grovel-syntax ctype (lisp-name size-designator)
304 (c-section-header out "ctype" lisp-name)
305 (c-export out lisp-name)
306 (c-format out "(cffi:defctype ")
307 (c-print-symbol out lisp-name t)
308 (c-format out " ")
309 (format out "~& type_name(output, TYPE_SIGNED_P(~A), ~:[sizeof(~A)~;~…
310 size-designator
311 (etypecase size-designator
312 (string nil)
313 (integer t))
314 size-designator)
315 (c-format out ")~%")
316 (unless (keywordp lisp-name)
317 (c-export out lisp-name))
318 (let ((size-of-constant-name (symbolicate '#:size-of- lisp-name)))
319 (c-export out size-of-constant-name)
320 (c-format out "(cl:defconstant "
321 size-of-constant-name lisp-name)
322 (c-print-symbol out size-of-constant-name)
323 (c-format out " (cffi:foreign-type-size '")
324 (c-print-symbol out lisp-name)
325 (c-format out "))~%")))
326
327 ;;; Syntax differs from anything else in CFFI. Fix?
328 (define-grovel-syntax constant ((lisp-name &rest c-names)
329 &key (type 'integer) documentation optio…
330 (when (keywordp lisp-name)
331 (setf lisp-name (format-symbol "~A" lisp-name)))
332 (c-section-header out "constant" lisp-name)
333 (dolist (c-name c-names)
334 (format out "~&#ifdef ~A~%" c-name)
335 (c-export out lisp-name)
336 (c-format out "(cl:defconstant ")
337 (c-print-symbol out lisp-name t)
338 (c-format out " ")
339 (ecase type
340 (integer
341 (format out "~& if(_64_BIT_VALUE_FITS_SIGNED_P(~A))~%" c-name)
342 (format out " fprintf(output, \"%lli\", (long long signed) ~A)…
343 (format out "~& else~%")
344 (format out " fprintf(output, \"%llu\", (long long unsigned) ~…
345 (double-float
346 (format out "~& fprintf(output, \"%s\", print_double_for_lisp((d…
347 (when documentation
348 (c-format out " ~S" documentation))
349 (c-format out ")~%")
350 (format out "~&#else~%"))
351 (unless optional
352 (c-format out "(cl:warn 'cffi-grovel:missing-definition :name '~A)~%"
353 lisp-name))
354 (dotimes (i (length c-names))
355 (format out "~&#endif~%")))
356
357 (define-grovel-syntax feature (lisp-feature-name c-name &key (feature-li…
358 (c-section-header out "feature" lisp-feature-name)
359 (format out "~&#ifdef ~A~%" c-name)
360 (c-format out "(cl:pushnew '")
361 (c-print-symbol out lisp-feature-name t)
362 (c-format out " ")
363 (c-print-symbol out feature-list)
364 (c-format out ")~%")
365 (format out "~&#endif~%"))
366
367 (define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots)
368 (let ((documentation (when (stringp (car slots)) (pop slots))))
369 (c-section-header out "cunion" union-lisp-name)
370 (c-export out union-lisp-name)
371 (dolist (slot slots)
372 (let ((slot-lisp-name (car slot)))
373 (c-export out slot-lisp-name)))
374 (c-format out "(cffi:defcunion (")
375 (c-print-symbol out union-lisp-name t)
376 (c-printf out " :size %llu)" (format nil "(long long unsigned) sizeo…
377 (when documentation
378 (c-format out "~% ~S" documentation))
379 (dolist (slot slots)
380 (destructuring-bind (slot-lisp-name slot-c-name &key type count)
381 slot
382 (declare (ignore slot-c-name))
383 (c-format out "~% (")
384 (c-print-symbol out slot-lisp-name t)
385 (c-format out " ")
386 (c-write out type)
387 (etypecase count
388 (integer
389 (c-format out " :count ~D" count))
390 ((eql :auto)
391 ;; nb, works like :count :auto does in cstruct below
392 (c-printf out " :count %llu"
393 (format nil "(long long unsigned) sizeof(~A)" union…
394 (null t))
395 (c-format out ")")))
396 (c-format out ")~%")))
397
398 (defun make-from-pointer-function-name (type-name)
399 (symbolicate '#:make- type-name '#:-from-pointer))
400
401 ;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
402 ;;; cleaner way to do this. Unless I can find any advantage in doing
403 ;;; it this way I'll delete this soon. --luis
404 (define-grovel-syntax cstruct-and-class-item (&rest arguments)
405 (process-grovel-form out (cons 'cstruct arguments))
406 (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
407 arguments
408 (declare (ignore struct-c-name))
409 (let* ((slot-names (mapcar #'car slots))
410 (reader-names (mapcar
411 (lambda (slot-name)
412 (intern
413 (strcat (symbol-name struct-lisp-name) "-"
414 (symbol-name slot-name))))
415 slot-names))
416 (initarg-names (mapcar
417 (lambda (slot-name)
418 (intern (symbol-name slot-name) "KEYWORD"))
419 slot-names))
420 (slot-decoders (mapcar (lambda (slot)
421 (destructuring-bind
422 (lisp-name c-name
423 &key type count
424 &allow-other-keys)
425 slot
426 (declare (ignore lisp-name c-name))
427 (cond ((and (eq type :char) count)
428 'cffi:foreign-string-to-lis…
429 (t nil))))
430 slots))
431 (defclass-form
432 `(defclass ,struct-lisp-name ()
433 ,(mapcar (lambda (slot-name initarg-name reader-name)
434 `(,slot-name :initarg ,initarg-name
435 :reader ,reader-name))
436 slot-names
437 initarg-names
438 reader-names)))
439 (make-function-name
440 (make-from-pointer-function-name struct-lisp-name))
441 (make-defun-form
442 ;; this function is then used as a constructor for this clas…
443 `(defun ,make-function-name (pointer)
444 (cffi:with-foreign-slots
445 (,slot-names pointer ,struct-lisp-name)
446 (make-instance ',struct-lisp-name
447 ,@(loop for slot-name in slot-names
448 for initarg-name in initarg-names
449 for slot-decoder in slot-decoders
450 collect initarg-name
451 if slot-decoder
452 collect `(,slot-decoder ,slot-na…
453 else collect slot-name))))))
454 (c-export out make-function-name)
455 (dolist (reader-name reader-names)
456 (c-export out reader-name))
457 (c-write out defclass-form)
458 (c-write out make-defun-form))))
459
460 (define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slot…
461 (let ((documentation (when (stringp (car slots)) (pop slots))))
462 (c-section-header out "cstruct" struct-lisp-name)
463 (c-export out struct-lisp-name)
464 (dolist (slot slots)
465 (let ((slot-lisp-name (car slot)))
466 (c-export out slot-lisp-name)))
467 (c-format out "(cffi:defcstruct (")
468 (c-print-symbol out struct-lisp-name t)
469 (c-printf out " :size %llu)"
470 (format nil "(long long unsigned) sizeof(~A)" struct-c-nam…
471 (when documentation
472 (c-format out "~% ~S" documentation))
473 (dolist (slot slots)
474 (destructuring-bind (slot-lisp-name slot-c-name &key type count)
475 slot
476 (c-format out "~% (")
477 (c-print-symbol out slot-lisp-name t)
478 (c-format out " ")
479 (etypecase type
480 ((eql :auto)
481 (format out "~& SLOT_SIGNED_P(autotype_tmp, ~A, ~A~@[[0]~]);…
482 ~& type_name(output, autotype_tmp, sizeofslot(~…
483 struct-c-name
484 slot-c-name
485 (not (null count))))
486 ((or cons symbol)
487 (c-write out type))
488 (string
489 (c-format out "~A" type)))
490 (etypecase count
491 (null t)
492 (integer
493 (c-format out " :count ~D" count))
494 ((eql :auto)
495 (c-printf out " :count %llu"
496 (format nil "(long long unsigned) countofslot(~A, ~…
497 struct-c-name
498 slot-c-name)))
499 ((or symbol string)
500 (format out "~&#ifdef ~A~%" count)
501 (c-printf out " :count %llu"
502 (format nil "(long long unsigned) (~A)" count))
503 (format out "~&#endif~%")))
504 (c-printf out " :offset %lli)"
505 (format nil "(long long signed) offsetof(~A, ~A)"
506 struct-c-name
507 slot-c-name))))
508 (c-format out ")~%")
509 (let ((size-of-constant-name
510 (symbolicate '#:size-of- struct-lisp-name)))
511 (c-export out size-of-constant-name)
512 (c-format out "(cl:defconstant "
513 size-of-constant-name struct-lisp-name)
514 (c-print-symbol out size-of-constant-name)
515 (c-format out " (cffi:foreign-type-size '(:struct ")
516 (c-print-symbol out struct-lisp-name)
517 (c-format out ")))~%"))))
518
519 (defmacro define-pseudo-cvar (str name type &key read-only)
520 (let ((c-parse (let ((*read-eval* nil)
521 (*readtable* (copy-readtable nil)))
522 (setf (readtable-case *readtable*) :preserve)
523 (read-from-string str))))
524 (typecase c-parse
525 (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name
526 :read-only ,read-only)
527 ,type))
528 (list (unless (and (= (length c-parse) 2)
529 (null (second c-parse))
530 (symbolp (first c-parse))
531 (eql #\* (char (symbol-name (first c-parse)) 0)…
532 (grovel-error "Unable to parse c-string ~s." str))
533 (let ((func-name (symbolicate "%" name '#:-accessor)))
534 `(progn
535 (declaim (inline ,func-name))
536 (cffi:defcfun (,(string-trim "*" (symbol-name (first c-…
537 ,func-name) :pointer)
538 (define-symbol-macro ,name
539 (cffi:mem-ref (,func-name) ',type)))))
540 (t (grovel-error "Unable to parse c-string ~s." str)))))
541
542 (defun foreign-name-to-symbol (s)
543 (intern (substitute #\- #\_ (string-upcase s))))
544
545 (defun choose-lisp-and-foreign-names (string-or-list)
546 (etypecase string-or-list
547 (string (values string-or-list (foreign-name-to-symbol string-or-lis…
548 (list (destructuring-bind (fname lname &rest args) string-or-list
549 (declare (ignore args))
550 (assert (and (stringp fname) (symbolp lname)))
551 (values fname lname)))))
552
553 (define-grovel-syntax cvar (name type &key read-only)
554 (multiple-value-bind (c-name lisp-name)
555 (choose-lisp-and-foreign-names name)
556 (c-section-header out "cvar" lisp-name)
557 (c-export out lisp-name)
558 (c-printf out "(cffi-grovel::define-pseudo-cvar \"%s\" "
559 (format nil "indirect_stringify(~A)" c-name))
560 (c-print-symbol out lisp-name t)
561 (c-format out " ")
562 (c-write out type)
563 (when read-only
564 (c-format out " :read-only t"))
565 (c-format out ")~%")))
566
567 ;;; FIXME: where would docs on enum elements go?
568 (define-grovel-syntax cenum (name &rest enum-list)
569 (destructuring-bind (name &key base-type define-constants)
570 (ensure-list name)
571 (c-section-header out "cenum" name)
572 (c-export out name)
573 (c-format out "(cffi:defcenum (")
574 (c-print-symbol out name t)
575 (when base-type
576 (c-printf out " ")
577 (c-print-symbol out base-type t))
578 (c-format out ")")
579 (dolist (enum enum-list)
580 (destructuring-bind ((lisp-name &rest c-names) &key documentation)
581 enum
582 (declare (ignore documentation))
583 (check-type lisp-name keyword)
584 (loop for c-name in c-names do
585 (check-type c-name string)
586 (c-format out " (")
587 (c-print-symbol out lisp-name)
588 (c-format out " ")
589 (c-print-integer-constant out c-name base-type)
590 (c-format out ")~%"))))
591 (c-format out ")~%")
592 (when define-constants
593 (define-constants-from-enum out enum-list))))
594
595 (define-grovel-syntax constantenum (name &rest enum-list)
596 (destructuring-bind (name &key base-type define-constants)
597 (ensure-list name)
598 (c-section-header out "constantenum" name)
599 (c-export out name)
600 (c-format out "(cffi:defcenum (")
601 (c-print-symbol out name t)
602 (when base-type
603 (c-printf out " ")
604 (c-print-symbol out base-type t))
605 (c-format out ")")
606 (dolist (enum enum-list)
607 (destructuring-bind ((lisp-name &rest c-names)
608 &key optional documentation) enum
609 (declare (ignore documentation))
610 (check-type lisp-name keyword)
611 (c-format out "~% (")
612 (c-print-symbol out lisp-name)
613 (loop for c-name in c-names do
614 (check-type c-name string)
615 (format out "~&#ifdef ~A~%" c-name)
616 (c-format out " ")
617 (c-print-integer-constant out c-name base-type)
618 (format out "~&#else~%"))
619 (unless optional
620 (c-format out
621 "~% #.(cl:progn ~
622 (cl:warn 'cffi-grovel:missing-definition :nam…
623 -1)"
624 lisp-name))
625 (dotimes (i (length c-names))
626 (format out "~&#endif~%"))
627 (c-format out ")")))
628 (c-format out ")~%")
629 (when define-constants
630 (define-constants-from-enum out enum-list))))
631
632 (defun define-constants-from-enum (out enum-list)
633 (dolist (enum enum-list)
634 (destructuring-bind ((lisp-name &rest c-names) &rest options)
635 enum
636 (%process-grovel-form
637 'constant out
638 `((,(intern (string lisp-name)) ,(car c-names))
639 ,@options)))))
640
641 (defun convert-intmax-constant (constant base-type)
642 "Convert the C CONSTANT to an integer of BASE-TYPE. The constant is
643 assumed to be an integer printed using the PRIiMAX printf(3) format
644 string."
645 ;; | C Constant | Type | Return Value | Notes …
646 ;; |------------+---------+--------------+----------------------------…
647 ;; | -1 | :int32 | -1 | …
648 ;; | 0xffffffff | :int32 | -1 | CONSTANT may be a positive …
649 ;; | | | | sizeof(intmax_t) > sizeof(i…
650 ;; | 0xffffffff | :uint32 | 4294967295 | …
651 ;; | -1 | :uint32 | 4294967295 | …
652 ;; |------------+---------+--------------+----------------------------…
653 (let* ((canonical-type (cffi::canonicalize-foreign-type base-type))
654 (type-bits (* 8 (cffi:foreign-type-size canonical-type)))
655 (2^n (ash 1 type-bits)))
656 (ecase canonical-type
657 ((:unsigned-char :unsigned-short :unsigned-int
658 :unsigned-long :unsigned-long-long)
659 (mod constant 2^n))
660 ((:char :short :int :long :long-long)
661 (let ((v (mod constant 2^n)))
662 (if (logbitp (1- type-bits) v)
663 (- (mask-field (byte (1- type-bits) 0) v)
664 (ash 1 (1- type-bits)))
665 v))))))
666
667 (defun foreign-type-to-printf-specification (type)
668 "Return the printf specification associated with the foreign type TYPE…
669 (ecase (cffi::canonicalize-foreign-type type)
670 (:char "\"%hhd\"")
671 (:unsigned-char "\"%hhu\"")
672 (:short "\"%hd\"")
673 (:unsigned-short "\"%hu\"")
674 (:int "\"%d\"")
675 (:unsigned-int "\"%u\"")
676 (:long "\"%ld\"")
677 (:unsigned-long "\"%lu\"")
678 (:long-long "\"%lld\"")
679 (:unsigned-long-long "\"%llu\"")))
680
681 ;; Defines a bitfield, with elements specified as ((LISP-NAME C-NAME)
682 ;; &key DOCUMENTATION). NAME-AND-OPTS can be either a symbol as name,
683 ;; or a list (NAME &key BASE-TYPE).
684 (define-grovel-syntax bitfield (name-and-opts &rest masks)
685 (destructuring-bind (name &key base-type)
686 (ensure-list name-and-opts)
687 (c-section-header out "bitfield" name)
688 (c-export out name)
689 (c-format out "(cffi:defbitfield (")
690 (c-print-symbol out name t)
691 (when base-type
692 (c-printf out " ")
693 (c-print-symbol out base-type t))
694 (c-format out ")")
695 (dolist (mask masks)
696 (destructuring-bind ((lisp-name &rest c-names)
697 &key optional documentation) mask
698 (declare (ignore documentation))
699 (check-type lisp-name symbol)
700 (c-format out "~% (")
701 (c-print-symbol out lisp-name)
702 (c-format out " ")
703 (dolist (c-name c-names)
704 (check-type c-name string)
705 (format out "~&#ifdef ~A~%" c-name)
706 (format out "~& fprintf(output, ~A, ~A);~%"
707 (foreign-type-to-printf-specification (or base-type :i…
708 c-name)
709 (format out "~&#else~%"))
710 (unless optional
711 (c-format out
712 "~% #.(cl:progn ~
713 (cl:warn 'cffi-grovel:missing-definition :nam…
714 -1)"
715 lisp-name))
716 (dotimes (i (length c-names))
717 (format out "~&#endif~%"))
718 (c-format out ")")))
719 (c-format out ")~%")))
720
721
722 ;;;# Wrapper Generation
723 ;;;
724 ;;; Here we generate a C file from a s-exp specification but instead
725 ;;; of compiling and running it, we compile it as a shared library
726 ;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
727 ;;;
728 ;;; Useful to get at macro functionality, errno, system calls,
729 ;;; functions that handle structures by value, etc...
730 ;;;
731 ;;; Matching CFFI bindings are generated along with said C file.
732
733 (defun process-wrapper-form (out form)
734 (%process-wrapper-form (form-kind form) out (cdr form)))
735
736 ;;; The various operators push Lisp forms onto this list which will be
737 ;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
738 (defvar *lisp-forms*)
739
740 (defun generate-c-lib-file (input-file output-defaults)
741 (let ((*lisp-forms* nil)
742 (c-file (make-c-file-name output-defaults "__wrapper")))
743 (with-open-file (out c-file :direction :output :if-exists :supersede)
744 (with-open-file (in input-file :direction :input)
745 (write-string *header* out)
746 (loop for form = (read in nil nil) while form
747 do (process-wrapper-form out form))))
748 (values c-file (nreverse *lisp-forms*))))
749
750 (defun make-soname (lib-soname output-defaults)
751 (make-pathname :name lib-soname
752 :defaults output-defaults))
753
754 (defun generate-bindings-file (lib-file lib-soname lisp-forms output-def…
755 (with-standard-io-syntax
756 (let ((lisp-file (tmp-lisp-file-name output-defaults))
757 (*print-readably* nil)
758 (*print-escape* t))
759 (with-open-file (out lisp-file :direction :output :if-exists :supe…
760 (format out ";;;; This file was automatically generated by cffi-…
761 ;;;; Do not edit by hand.~%")
762 (let ((*package* (find-package '#:cl))
763 (named-library-name
764 (let ((*package* (find-package :keyword))
765 (*read-eval* nil))
766 (read-from-string lib-soname))))
767 (pprint `(progn
768 (cffi:define-foreign-library
769 (,named-library-name
770 :type :grovel-wrapper
771 :search-path ,(directory-namestring lib-file))
772 (t ,(namestring (make-so-file-name lib-soname))))
773 (cffi:use-foreign-library ,named-library-name))
774 out)
775 (fresh-line out))
776 (dolist (form lisp-forms)
777 (print form out))
778 (terpri out))
779 lisp-file)))
780
781 (defun cc-include-grovel-argument ()
782 (format nil "-I~A" (truename (system-source-directory :cffi-grovel))))
783
784 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
785 ;;; *the extent of a given wrapper file.
786 (defun process-wrapper-file (input-file
787 &key
788 (output-defaults (make-pathname :defaults…
789 lib-soname)
790 (with-standard-io-syntax
791 (multiple-value-bind (c-file lisp-forms)
792 (generate-c-lib-file input-file output-defaults)
793 (let ((lib-file (make-so-file-name (make-soname lib-soname output-de…
794 (o-file (make-o-file-name output-defaults "__wrapper")))
795 (cc-compile o-file (list (cc-include-grovel-argument) c-file))
796 (link-shared-library lib-file (list o-file))
797 ;; FIXME: hardcoded library path.
798 (values (generate-bindings-file lib-file lib-soname lisp-forms o…
799 lib-file)))))
800
801 (defgeneric %process-wrapper-form (name out arguments)
802 (:method (name out arguments)
803 (declare (ignore out arguments))
804 (grovel-error "Unknown Grovel syntax: ~S" name)))
805
806 ;;; OUT is lexically bound to the output stream within BODY.
807 (defmacro define-wrapper-syntax (name lambda-list &body body)
808 (with-unique-names (name-var args)
809 `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,arg…
810 (declare (ignorable out))
811 (destructuring-bind ,lambda-list ,args
812 ,@body))))
813
814 (define-wrapper-syntax progn (&rest forms)
815 (dolist (form forms)
816 (process-wrapper-form out form)))
817
818 (define-wrapper-syntax in-package (name)
819 (assert (find-package name) (name)
820 "Wrapper file specified (in-package ~s)~%~
821 however that does not name a known package."
822 name)
823 (setq *package* (find-package name))
824 (push `(in-package ,name) *lisp-forms*))
825
826 (define-wrapper-syntax c (&rest strings)
827 (dolist (string strings)
828 (write-line string out)))
829
830 (define-wrapper-syntax flag (&rest flags)
831 (appendf *cc-flags* (parse-command-flags-list flags)))
832
833 (define-wrapper-syntax proclaim (&rest proclamations)
834 (push `(proclaim ,@proclamations) *lisp-forms*))
835
836 (define-wrapper-syntax declaim (&rest declamations)
837 (push `(declaim ,@declamations) *lisp-forms*))
838
839 (define-wrapper-syntax define (name &optional value)
840 (format out "#define ~A~@[ ~A~]~%" name value))
841
842 (define-wrapper-syntax include (&rest includes)
843 (format out "~{#include <~A>~%~}" includes))
844
845 ;;; FIXME: this function is not complete. Should probably follow
846 ;;; typedefs? Should definitely understand pointer types.
847 (defun c-type-name (typespec)
848 (let ((spec (ensure-list typespec)))
849 (if (stringp (car spec))
850 (car spec)
851 (case (car spec)
852 ((:uchar :unsigned-char) "unsigned char")
853 ((:unsigned-short :ushort) "unsigned short")
854 ((:unsigned-int :uint) "unsigned int")
855 ((:unsigned-long :ulong) "unsigned long")
856 ((:long-long :llong) "long long")
857 ((:unsigned-long-long :ullong) "unsigned long long")
858 (:pointer "void*")
859 (:string "char*")
860 (t (cffi::foreign-name (car spec) nil))))))
861
862 (defun cffi-type (typespec)
863 (if (and (listp typespec) (stringp (car typespec)))
864 (second typespec)
865 typespec))
866
867 (defun symbol* (s)
868 (check-type s (and symbol (not null)))
869 s)
870
871 (define-wrapper-syntax defwrapper (name-and-options rettype &rest args)
872 (multiple-value-bind (lisp-name foreign-name options)
873 (cffi::parse-name-and-options name-and-options)
874 (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
875 (fargs (mapcar (lambda (arg)
876 (list (c-type-name (second arg))
877 (cffi::foreign-name (first arg) nil)))
878 args))
879 (fargnames (mapcar #'second fargs)))
880 ;; output C code
881 (format out "~A ~A" (c-type-name rettype) foreign-name-wrap)
882 (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
883 (format out "{~% return ~A(~{~A~^, ~});~%}~%~%" foreign-name farg…
884 ;; matching bindings
885 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
886 ,(cffi-type rettype)
887 ,@(mapcar (lambda (arg)
888 (list (symbol* (first arg))
889 (cffi-type (second arg))))
890 args))
891 *lisp-forms*))))
892
893 (define-wrapper-syntax defwrapper* (name-and-options rettype args &rest …
894 ;; output C code
895 (multiple-value-bind (lisp-name foreign-name options)
896 (cffi::parse-name-and-options name-and-options)
897 (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
898 (fargs (mapcar (lambda (arg)
899 (list (c-type-name (second arg))
900 (cffi::foreign-name (first arg) nil)))
901 args)))
902 (format out "~A ~A" (c-type-name rettype)
903 foreign-name-wrap)
904 (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
905 (format out "{~%~{ ~A~%~}}~%~%" c-lines)
906 ;; matching bindings
907 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
908 ,(cffi-type rettype)
909 ,@(mapcar (lambda (arg)
910 (list (symbol* (first arg))
911 (cffi-type (second arg))))
912 args))
913 *lisp-forms*))))
You are viewing proxied material from bitreich.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.