grovel: improve IN-PACKAGE error handling
[cffi.git] / grovel / grovel.lisp
blob004620d8d4effae8230f3386545292308dd8e3f6
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; grovel.lisp --- The CFFI Groveller.
4 ;;;
5 ;;; Copyright (C) 2005-2006, Dan Knap <dankna@accela.net>
6 ;;; Copyright (C) 2005-2006, Emily Backes <lucca@accela.net>
7 ;;; Copyright (C) 2007, Stelian Ionescu <sionescu@cddr.org>
8 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
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 ;;;
31 (in-package #:cffi-grovel)
33 ;;;# Error Conditions
35 (define-condition grovel-error (simple-error) ())
37 (defun grovel-error (format-control &rest format-arguments)
38 (error 'grovel-error
39 :format-control format-control
40 :format-arguments format-arguments))
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)))))
50 ;;;# Grovelling
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.
61 ;;; C code generated by cffi-grovel is inserted between the contents
62 ;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.
64 (defparameter *prologue*
66 #include <grovel/common.h>
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\");
75 (defparameter *postscript*
77 if (output != stdout)
78 fclose(output);
79 return 0;
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))))))
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)))
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 ");~%")))
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 ")")))
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))
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))))
146 ;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
147 ;;; later, if necessary.
148 (defvar *auto-export* nil)
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 ")~%")))
156 (defun c-section-header (out section-type section-symbol)
157 (format out "~% /* ~A section for ~S */~%"
158 section-type
159 section-symbol))
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)))
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)))
173 (defun process-grovel-form (out form)
174 (%process-grovel-form (form-kind form) out (cdr form)))
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))
182 (defvar *header-forms* '(c include define flag typedef))
184 (defun header-form-p (form)
185 (member (form-kind form) *header-forms*))
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, use CC-FLAGS instead.")))
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)))
224 (defun tmp-lisp-file-name (defaults)
225 (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp")
226 :type "lisp" :defaults defaults))
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-file))
233 (with-standard-io-syntax
234 (let* ((c-file (generate-c-file input-file output-defaults))
235 (exe-file (make-exe-file-name c-file))
236 (lisp-file (tmp-lisp-file-name c-file))
237 (inputs (list (cc-include-grovel-argument) c-file)))
238 (handler-case
239 (link-executable exe-file inputs)
240 (error (e)
241 (grovel-error "~a" e)))
242 (invoke exe-file lisp-file)
243 lisp-file)))
245 ;;; OUT is lexically bound to the output stream within BODY.
246 (defmacro define-grovel-syntax (name lambda-list &body body)
247 (with-unique-names (name-var args)
248 `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args)
249 (declare (ignorable out))
250 (destructuring-bind ,lambda-list ,args
251 ,@body))))
253 (define-grovel-syntax c (body)
254 (format out "~%~A~%" body))
256 (define-grovel-syntax include (&rest includes)
257 (format out "~{#include <~A>~%~}" includes))
259 (define-grovel-syntax define (name &optional value)
260 (format out "#define ~A~@[ ~A~]~%" name value))
262 (define-grovel-syntax typedef (base-type new-type)
263 (format out "typedef ~A ~A;~%" base-type new-type))
265 ;;; Is this really needed?
266 (define-grovel-syntax ffi-typedef (new-type base-type)
267 (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type))
269 (define-grovel-syntax flag (&rest flags)
270 (appendf *cc-flags* (parse-command-flags-list flags)))
272 (define-grovel-syntax cc-flags (&rest flags)
273 (appendf *cc-flags* (parse-command-flags-list flags)))
275 (define-grovel-syntax pkg-config-cflags (pkg &key optional)
276 (let ((output-stream (make-string-output-stream))
277 (program+args (list "pkg-config" pkg "--cflags")))
278 (format *debug-io* "~&;~{ ~a~}~%" program+args)
279 (handler-case
280 (progn
281 (run-program program+args
282 :output (make-broadcast-stream output-stream *debug-io*)
283 :error-output output-stream)
284 (appendf *cc-flags*
285 (parse-command-flags (get-output-stream-string output-stream))))
286 (error (e)
287 (let ((message (format nil "~a~&~%~a~&"
288 e (get-output-stream-string output-stream))))
289 (cond (optional
290 (format *debug-io* "~&; ERROR: ~a" message)
291 (format *debug-io* "~&~%; Attempting to continue anyway.~%"))
293 (grovel-error "~a" message))))))))
295 ;;; This form also has some "read time" effects. See GENERATE-C-FILE.
296 (define-grovel-syntax in-package (name)
297 (c-format out "(cl:in-package #:~A)~%~%" name))
299 (define-grovel-syntax ctype (lisp-name size-designator)
300 (c-section-header out "ctype" lisp-name)
301 (c-export out lisp-name)
302 (c-format out "(cffi:defctype ")
303 (c-print-symbol out lisp-name t)
304 (c-format out " ")
305 (format out "~& type_name(output, TYPE_SIGNED_P(~A), ~:[sizeof(~A)~;~D~]);~%"
306 size-designator
307 (etypecase size-designator
308 (string nil)
309 (integer t))
310 size-designator)
311 (c-format out ")~%")
312 (unless (keywordp lisp-name)
313 (c-export out lisp-name))
314 (let ((size-of-constant-name (symbolicate '#:size-of- lisp-name)))
315 (c-export out size-of-constant-name)
316 (c-format out "(cl:defconstant "
317 size-of-constant-name lisp-name)
318 (c-print-symbol out size-of-constant-name)
319 (c-format out " (cffi:foreign-type-size '")
320 (c-print-symbol out lisp-name)
321 (c-format out "))~%")))
323 ;;; Syntax differs from anything else in CFFI. Fix?
324 (define-grovel-syntax constant ((lisp-name &rest c-names)
325 &key (type 'integer) documentation optional)
326 (when (keywordp lisp-name)
327 (setf lisp-name (format-symbol "~A" lisp-name)))
328 (c-section-header out "constant" lisp-name)
329 (dolist (c-name c-names)
330 (format out "~&#ifdef ~A~%" c-name)
331 (c-export out lisp-name)
332 (c-format out "(cl:defconstant ")
333 (c-print-symbol out lisp-name t)
334 (c-format out " ")
335 (ecase type
336 (integer
337 (format out "~& if(_64_BIT_VALUE_FITS_SIGNED_P(~A))~%" c-name)
338 (format out " fprintf(output, \"%lli\", (long long signed) ~A);" c-name)
339 (format out "~& else~%")
340 (format out " fprintf(output, \"%llu\", (long long unsigned) ~A);" c-name))
341 (double-float
342 (format out "~& fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name)))
343 (when documentation
344 (c-format out " ~S" documentation))
345 (c-format out ")~%")
346 (format out "~&#else~%"))
347 (unless optional
348 (c-format out "(cl:warn 'cffi-grovel:missing-definition :name '~A)~%"
349 lisp-name))
350 (dotimes (i (length c-names))
351 (format out "~&#endif~%")))
353 (define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots)
354 (let ((documentation (when (stringp (car slots)) (pop slots))))
355 (c-section-header out "cunion" union-lisp-name)
356 (c-export out union-lisp-name)
357 (dolist (slot slots)
358 (let ((slot-lisp-name (car slot)))
359 (c-export out slot-lisp-name)))
360 (c-format out "(cffi:defcunion (")
361 (c-print-symbol out union-lisp-name t)
362 (c-printf out " :size %llu)" (format nil "(long long unsigned) sizeof(~A)" union-c-name))
363 (when documentation
364 (c-format out "~% ~S" documentation))
365 (dolist (slot slots)
366 (destructuring-bind (slot-lisp-name slot-c-name &key type count)
367 slot
368 (declare (ignore slot-c-name))
369 (c-format out "~% (")
370 (c-print-symbol out slot-lisp-name t)
371 (c-format out " ")
372 (c-write out type)
373 (etypecase count
374 (integer
375 (c-format out " :count ~D" count))
376 ((eql :auto)
377 ;; nb, works like :count :auto does in cstruct below
378 (c-printf out " :count %llu"
379 (format nil "(long long unsigned) sizeof(~A)" union-c-name)))
380 (null t))
381 (c-format out ")")))
382 (c-format out ")~%")))
384 (defun make-from-pointer-function-name (type-name)
385 (symbolicate '#:make- type-name '#:-from-pointer))
387 ;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
388 ;;; cleaner way to do this. Unless I can find any advantage in doing
389 ;;; it this way I'll delete this soon. --luis
390 (define-grovel-syntax cstruct-and-class-item (&rest arguments)
391 (process-grovel-form out (cons 'cstruct arguments))
392 (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
393 arguments
394 (declare (ignore struct-c-name))
395 (let* ((slot-names (mapcar #'car slots))
396 (reader-names (mapcar
397 (lambda (slot-name)
398 (intern
399 (strcat (symbol-name struct-lisp-name) "-"
400 (symbol-name slot-name))))
401 slot-names))
402 (initarg-names (mapcar
403 (lambda (slot-name)
404 (intern (symbol-name slot-name) "KEYWORD"))
405 slot-names))
406 (slot-decoders (mapcar (lambda (slot)
407 (destructuring-bind
408 (lisp-name c-name
409 &key type count
410 &allow-other-keys)
411 slot
412 (declare (ignore lisp-name c-name))
413 (cond ((and (eq type :char) count)
414 'cffi:foreign-string-to-lisp)
415 (t nil))))
416 slots))
417 (defclass-form
418 `(defclass ,struct-lisp-name ()
419 ,(mapcar (lambda (slot-name initarg-name reader-name)
420 `(,slot-name :initarg ,initarg-name
421 :reader ,reader-name))
422 slot-names
423 initarg-names
424 reader-names)))
425 (make-function-name
426 (make-from-pointer-function-name struct-lisp-name))
427 (make-defun-form
428 ;; this function is then used as a constructor for this class.
429 `(defun ,make-function-name (pointer)
430 (cffi:with-foreign-slots
431 (,slot-names pointer ,struct-lisp-name)
432 (make-instance ',struct-lisp-name
433 ,@(loop for slot-name in slot-names
434 for initarg-name in initarg-names
435 for slot-decoder in slot-decoders
436 collect initarg-name
437 if slot-decoder
438 collect `(,slot-decoder ,slot-name)
439 else collect slot-name))))))
440 (c-export out make-function-name)
441 (dolist (reader-name reader-names)
442 (c-export out reader-name))
443 (c-write out defclass-form)
444 (c-write out make-defun-form))))
446 (define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slots)
447 (let ((documentation (when (stringp (car slots)) (pop slots))))
448 (c-section-header out "cstruct" struct-lisp-name)
449 (c-export out struct-lisp-name)
450 (dolist (slot slots)
451 (let ((slot-lisp-name (car slot)))
452 (c-export out slot-lisp-name)))
453 (c-format out "(cffi:defcstruct (")
454 (c-print-symbol out struct-lisp-name t)
455 (c-printf out " :size %llu)"
456 (format nil "(long long unsigned) sizeof(~A)" struct-c-name))
457 (when documentation
458 (c-format out "~% ~S" documentation))
459 (dolist (slot slots)
460 (destructuring-bind (slot-lisp-name slot-c-name &key type count)
461 slot
462 (c-format out "~% (")
463 (c-print-symbol out slot-lisp-name t)
464 (c-format out " ")
465 (etypecase type
466 ((eql :auto)
467 (format out "~& SLOT_SIGNED_P(autotype_tmp, ~A, ~A~@[[0]~]);~@*~%~
468 ~& type_name(output, autotype_tmp, sizeofslot(~A, ~A~@[[0]~]));~%"
469 struct-c-name
470 slot-c-name
471 (not (null count))))
472 ((or cons symbol)
473 (c-write out type))
474 (string
475 (c-format out "~A" type)))
476 (etypecase count
477 (null t)
478 (integer
479 (c-format out " :count ~D" count))
480 ((eql :auto)
481 (c-printf out " :count %llu"
482 (format nil "(long long unsigned) countofslot(~A, ~A)"
483 struct-c-name
484 slot-c-name)))
485 ((or symbol string)
486 (format out "~&#ifdef ~A~%" count)
487 (c-printf out " :count %llu"
488 (format nil "(long long unsigned) (~A)" count))
489 (format out "~&#endif~%")))
490 (c-printf out " :offset %lli)"
491 (format nil "(long long signed) offsetof(~A, ~A)"
492 struct-c-name
493 slot-c-name))))
494 (c-format out ")~%")
495 (let ((size-of-constant-name
496 (symbolicate '#:size-of- struct-lisp-name)))
497 (c-export out size-of-constant-name)
498 (c-format out "(cl:defconstant "
499 size-of-constant-name struct-lisp-name)
500 (c-print-symbol out size-of-constant-name)
501 (c-format out " (cffi:foreign-type-size '(:struct ")
502 (c-print-symbol out struct-lisp-name)
503 (c-format out ")))~%"))))
505 (defmacro define-pseudo-cvar (str name type &key read-only)
506 (let ((c-parse (let ((*read-eval* nil)
507 (*readtable* (copy-readtable nil)))
508 (setf (readtable-case *readtable*) :preserve)
509 (read-from-string str))))
510 (typecase c-parse
511 (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name
512 :read-only ,read-only)
513 ,type))
514 (list (unless (and (= (length c-parse) 2)
515 (null (second c-parse))
516 (symbolp (first c-parse))
517 (eql #\* (char (symbol-name (first c-parse)) 0)))
518 (grovel-error "Unable to parse c-string ~s." str))
519 (let ((func-name (symbolicate "%" name '#:-accessor)))
520 `(progn
521 (declaim (inline ,func-name))
522 (cffi:defcfun (,(string-trim "*" (symbol-name (first c-parse)))
523 ,func-name) :pointer)
524 (define-symbol-macro ,name
525 (cffi:mem-ref (,func-name) ',type)))))
526 (t (grovel-error "Unable to parse c-string ~s." str)))))
528 (defun foreign-name-to-symbol (s)
529 (intern (substitute #\- #\_ (string-upcase s))))
531 (defun choose-lisp-and-foreign-names (string-or-list)
532 (etypecase string-or-list
533 (string (values string-or-list (foreign-name-to-symbol string-or-list)))
534 (list (destructuring-bind (fname lname &rest args) string-or-list
535 (declare (ignore args))
536 (assert (and (stringp fname) (symbolp lname)))
537 (values fname lname)))))
539 (define-grovel-syntax cvar (name type &key read-only)
540 (multiple-value-bind (c-name lisp-name)
541 (choose-lisp-and-foreign-names name)
542 (c-section-header out "cvar" lisp-name)
543 (c-export out lisp-name)
544 (c-printf out "(cffi-grovel::define-pseudo-cvar \"%s\" "
545 (format nil "indirect_stringify(~A)" c-name))
546 (c-print-symbol out lisp-name t)
547 (c-format out " ")
548 (c-write out type)
549 (when read-only
550 (c-format out " :read-only t"))
551 (c-format out ")~%")))
553 ;;; FIXME: where would docs on enum elements go?
554 (define-grovel-syntax cenum (name &rest enum-list)
555 (destructuring-bind (name &key base-type define-constants)
556 (ensure-list name)
557 (c-section-header out "cenum" name)
558 (c-export out name)
559 (c-format out "(cffi:defcenum (")
560 (c-print-symbol out name t)
561 (when base-type
562 (c-printf out " ")
563 (c-print-symbol out base-type t))
564 (c-format out ")")
565 (dolist (enum enum-list)
566 (destructuring-bind ((lisp-name &rest c-names) &key documentation)
567 enum
568 (declare (ignore documentation))
569 (check-type lisp-name keyword)
570 (loop for c-name in c-names do
571 (check-type c-name string)
572 (c-format out " (")
573 (c-print-symbol out lisp-name)
574 (c-format out " ")
575 (c-print-integer-constant out c-name base-type)
576 (c-format out ")~%"))))
577 (c-format out ")~%")
578 (when define-constants
579 (define-constants-from-enum out enum-list))))
581 (define-grovel-syntax constantenum (name &rest enum-list)
582 (destructuring-bind (name &key base-type define-constants)
583 (ensure-list name)
584 (c-section-header out "constantenum" name)
585 (c-export out name)
586 (c-format out "(cffi:defcenum (")
587 (c-print-symbol out name t)
588 (when base-type
589 (c-printf out " ")
590 (c-print-symbol out base-type t))
591 (c-format out ")")
592 (dolist (enum enum-list)
593 (destructuring-bind ((lisp-name &rest c-names)
594 &key optional documentation) enum
595 (declare (ignore documentation))
596 (check-type lisp-name keyword)
597 (c-format out "~% (")
598 (c-print-symbol out lisp-name)
599 (loop for c-name in c-names do
600 (check-type c-name string)
601 (format out "~&#ifdef ~A~%" c-name)
602 (c-format out " ")
603 (c-print-integer-constant out c-name base-type)
604 (format out "~&#else~%"))
605 (unless optional
606 (c-format out
607 "~% #.(cl:progn ~
608 (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
609 -1)"
610 lisp-name))
611 (dotimes (i (length c-names))
612 (format out "~&#endif~%"))
613 (c-format out ")")))
614 (c-format out ")~%")
615 (when define-constants
616 (define-constants-from-enum out enum-list))))
618 (defun define-constants-from-enum (out enum-list)
619 (dolist (enum enum-list)
620 (destructuring-bind ((lisp-name &rest c-names) &rest options)
621 enum
622 (%process-grovel-form
623 'constant out
624 `((,(intern (string lisp-name)) ,(car c-names))
625 ,@options)))))
627 (defun convert-intmax-constant (constant base-type)
628 "Convert the C CONSTANT to an integer of BASE-TYPE. The constant is
629 assumed to be an integer printed using the PRIiMAX printf(3) format
630 string."
631 ;; | C Constant | Type | Return Value | Notes |
632 ;; |------------+---------+--------------+---------------------------------------|
633 ;; | -1 | :int32 | -1 | |
634 ;; | 0xffffffff | :int32 | -1 | CONSTANT may be a positive integer if |
635 ;; | | | | sizeof(intmax_t) > sizeof(int32_t) |
636 ;; | 0xffffffff | :uint32 | 4294967295 | |
637 ;; | -1 | :uint32 | 4294967295 | |
638 ;; |------------+---------+--------------+---------------------------------------|
639 (let* ((canonical-type (cffi::canonicalize-foreign-type base-type))
640 (type-bits (* 8 (cffi:foreign-type-size canonical-type)))
641 (2^n (ash 1 type-bits)))
642 (ecase canonical-type
643 ((:unsigned-char :unsigned-short :unsigned-int
644 :unsigned-long :unsigned-long-long)
645 (mod constant 2^n))
646 ((:char :short :int :long :long-long)
647 (let ((v (mod constant 2^n)))
648 (if (logbitp (1- type-bits) v)
649 (- (mask-field (byte (1- type-bits) 0) v)
650 (ash 1 (1- type-bits)))
651 v))))))
653 (defun foreign-type-to-printf-specification (type)
654 "Return the printf specification associated with the foreign type TYPE."
655 (ecase (cffi::canonicalize-foreign-type type)
656 (:char "\"%hhd\"")
657 (:unsigned-char "\"%hhu\"")
658 (:short "\"%hd\"")
659 (:unsigned-short "\"%hu\"")
660 (:int "\"%d\"")
661 (:unsigned-int "\"%u\"")
662 (:long "\"%ld\"")
663 (:unsigned-long "\"%lu\"")
664 (:long-long "\"%lld\"")
665 (:unsigned-long-long "\"%llu\"")))
667 ;; Defines a bitfield, with elements specified as ((LISP-NAME C-NAME)
668 ;; &key DOCUMENTATION). NAME-AND-OPTS can be either a symbol as name,
669 ;; or a list (NAME &key BASE-TYPE).
670 (define-grovel-syntax bitfield (name-and-opts &rest masks)
671 (destructuring-bind (name &key base-type)
672 (ensure-list name-and-opts)
673 (c-section-header out "bitfield" name)
674 (c-export out name)
675 (c-format out "(cffi:defbitfield (")
676 (c-print-symbol out name t)
677 (when base-type
678 (c-printf out " ")
679 (c-print-symbol out base-type t))
680 (c-format out ")")
681 (dolist (mask masks)
682 (destructuring-bind ((lisp-name &rest c-names)
683 &key optional documentation) mask
684 (declare (ignore documentation))
685 (check-type lisp-name symbol)
686 (c-format out "~% (")
687 (c-print-symbol out lisp-name)
688 (c-format out " ")
689 (dolist (c-name c-names)
690 (check-type c-name string)
691 (format out "~&#ifdef ~A~%" c-name)
692 (format out "~& fprintf(output, ~A, ~A);~%"
693 (foreign-type-to-printf-specification (or base-type :int))
694 c-name)
695 (format out "~&#else~%"))
696 (unless optional
697 (c-format out
698 "~% #.(cl:progn ~
699 (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
700 -1)"
701 lisp-name))
702 (dotimes (i (length c-names))
703 (format out "~&#endif~%"))
704 (c-format out ")")))
705 (c-format out ")~%")))
708 ;;;# Wrapper Generation
710 ;;; Here we generate a C file from a s-exp specification but instead
711 ;;; of compiling and running it, we compile it as a shared library
712 ;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
714 ;;; Useful to get at macro functionality, errno, system calls,
715 ;;; functions that handle structures by value, etc...
717 ;;; Matching CFFI bindings are generated along with said C file.
719 (defun process-wrapper-form (out form)
720 (%process-wrapper-form (form-kind form) out (cdr form)))
722 ;;; The various operators push Lisp forms onto this list which will be
723 ;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
724 (defvar *lisp-forms*)
726 (defun generate-c-lib-file (input-file output-defaults)
727 (let ((*lisp-forms* nil)
728 (c-file (make-c-file-name output-defaults "__wrapper")))
729 (with-open-file (out c-file :direction :output :if-exists :supersede)
730 (with-open-file (in input-file :direction :input)
731 (write-string *header* out)
732 (loop for form = (read in nil nil) while form
733 do (process-wrapper-form out form))))
734 (values c-file (nreverse *lisp-forms*))))
736 (defun make-soname (lib-soname output-defaults)
737 (make-pathname :name lib-soname
738 :defaults output-defaults))
740 (defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults)
741 (with-standard-io-syntax
742 (let ((lisp-file (tmp-lisp-file-name output-defaults))
743 (*print-readably* nil)
744 (*print-escape* t))
745 (with-open-file (out lisp-file :direction :output :if-exists :supersede)
746 (format out ";;;; This file was automatically generated by cffi-grovel.~%~
747 ;;;; Do not edit by hand.~%")
748 (let ((*package* (find-package '#:cl))
749 (named-library-name
750 (let ((*package* (find-package :keyword))
751 (*read-eval* nil))
752 (read-from-string lib-soname))))
753 (pprint `(progn
754 (cffi:define-foreign-library
755 (,named-library-name
756 :type :grovel-wrapper
757 :search-path ,(directory-namestring lib-file))
758 (t ,(namestring (make-lib-file-name lib-soname))))
759 (cffi:use-foreign-library ,named-library-name))
760 out)
761 (fresh-line out))
762 (dolist (form lisp-forms)
763 (print form out))
764 (terpri out))
765 lisp-file)))
767 (defun cc-include-grovel-argument ()
768 (format nil "-I~A" (truename (system-source-directory :cffi-grovel))))
770 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
771 ;;; *the extent of a given wrapper file.
772 (defun process-wrapper-file (input-file
773 &key
774 (output-defaults (make-pathname :defaults input-file :type "processed"))
775 lib-soname)
776 (with-standard-io-syntax
777 (multiple-value-bind (c-file lisp-forms)
778 (generate-c-lib-file input-file output-defaults)
779 (let ((lib-file (make-lib-file-name (make-soname lib-soname output-defaults)))
780 (o-file (make-o-file-name output-defaults "__wrapper")))
781 (cc-compile o-file (list (cc-include-grovel-argument) c-file))
782 (link-shared-library lib-file (list o-file))
783 ;; FIXME: hardcoded library path.
784 (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults)
785 lib-file)))))
787 (defgeneric %process-wrapper-form (name out arguments)
788 (:method (name out arguments)
789 (declare (ignore out arguments))
790 (grovel-error "Unknown Grovel syntax: ~S" name)))
792 ;;; OUT is lexically bound to the output stream within BODY.
793 (defmacro define-wrapper-syntax (name lambda-list &body body)
794 (with-unique-names (name-var args)
795 `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,args)
796 (declare (ignorable out))
797 (destructuring-bind ,lambda-list ,args
798 ,@body))))
800 (define-wrapper-syntax progn (&rest forms)
801 (dolist (form forms)
802 (process-wrapper-form out form)))
804 (define-wrapper-syntax in-package (name)
805 (assert (find-package name) (name)
806 "Wrapper file specified (in-package ~s)~%~
807 however that does not name a known package."
808 name)
809 (setq *package* (find-package name))
810 (push `(in-package ,name) *lisp-forms*))
812 (define-wrapper-syntax c (&rest strings)
813 (dolist (string strings)
814 (write-line string out)))
816 (define-wrapper-syntax flag (&rest flags)
817 (appendf *cc-flags* (parse-command-flags-list flags)))
819 (define-wrapper-syntax proclaim (&rest proclamations)
820 (push `(proclaim ,@proclamations) *lisp-forms*))
822 (define-wrapper-syntax declaim (&rest declamations)
823 (push `(declaim ,@declamations) *lisp-forms*))
825 (define-wrapper-syntax define (name &optional value)
826 (format out "#define ~A~@[ ~A~]~%" name value))
828 (define-wrapper-syntax include (&rest includes)
829 (format out "~{#include <~A>~%~}" includes))
831 ;;; FIXME: this function is not complete. Should probably follow
832 ;;; typedefs? Should definitely understand pointer types.
833 (defun c-type-name (typespec)
834 (let ((spec (ensure-list typespec)))
835 (if (stringp (car spec))
836 (car spec)
837 (case (car spec)
838 ((:uchar :unsigned-char) "unsigned char")
839 ((:unsigned-short :ushort) "unsigned short")
840 ((:unsigned-int :uint) "unsigned int")
841 ((:unsigned-long :ulong) "unsigned long")
842 ((:long-long :llong) "long long")
843 ((:unsigned-long-long :ullong) "unsigned long long")
844 (:pointer "void*")
845 (:string "char*")
846 (t (cffi::foreign-name (car spec) nil))))))
848 (defun cffi-type (typespec)
849 (if (and (listp typespec) (stringp (car typespec)))
850 (second typespec)
851 typespec))
853 (defun symbol* (s)
854 (check-type s (and symbol (not null)))
857 (define-wrapper-syntax defwrapper (name-and-options rettype &rest args)
858 (multiple-value-bind (lisp-name foreign-name options)
859 (cffi::parse-name-and-options name-and-options)
860 (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
861 (fargs (mapcar (lambda (arg)
862 (list (c-type-name (second arg))
863 (cffi::foreign-name (first arg) nil)))
864 args))
865 (fargnames (mapcar #'second fargs)))
866 ;; output C code
867 (format out "~A ~A" (c-type-name rettype) foreign-name-wrap)
868 (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
869 (format out "{~% return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames)
870 ;; matching bindings
871 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
872 ,(cffi-type rettype)
873 ,@(mapcar (lambda (arg)
874 (list (symbol* (first arg))
875 (cffi-type (second arg))))
876 args))
877 *lisp-forms*))))
879 (define-wrapper-syntax defwrapper* (name-and-options rettype args &rest c-lines)
880 ;; output C code
881 (multiple-value-bind (lisp-name foreign-name options)
882 (cffi::parse-name-and-options name-and-options)
883 (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
884 (fargs (mapcar (lambda (arg)
885 (list (c-type-name (second arg))
886 (cffi::foreign-name (first arg) nil)))
887 args)))
888 (format out "~A ~A" (c-type-name rettype)
889 foreign-name-wrap)
890 (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
891 (format out "{~%~{ ~A~%~}}~%~%" c-lines)
892 ;; matching bindings
893 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
894 ,(cffi-type rettype)
895 ,@(mapcar (lambda (arg)
896 (list (symbol* (first arg))
897 (cffi-type (second arg))))
898 args))
899 *lisp-forms*))))