grovel.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
grovel.lisp (36543B)
---
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 ;;;
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, 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)))
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-file))
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 *debug-io*)
287 :error-output output-stream)
288 (appendf *cc-flags*
289 (parse-command-flags (get-output-stream-string output-stream))))
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)~;~D~]);~%"
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 optional)
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);" c-name)
343 (format out "~& else~%")
344 (format out " fprintf(output, \"%llu\", (long long unsigned) ~A);" c-name))
345 (double-float
346 (format out "~& fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name)))
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-list 'cl:*features*))
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) sizeof(~A)" union-c-name))
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-c-name)))
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-lisp)
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 class.
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-name)
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 slots)
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-name))
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(~A, ~A~@[[0]~]));~%"
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, ~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-parse)))
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-list)))
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 :name '~A) ~
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 integer if |
649 ;; | | | | sizeof(intmax_t) > sizeof(int32_t) |
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 :int))
708 c-name)
709 (format out "~&#else~%"))
710 (unless optional
711 (c-format out
712 "~% #.(cl:progn ~
713 (cl:warn 'cffi-grovel:missing-definition :name '~A) ~
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-defaults)
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 :supersede)
760 (format out ";;;; This file was automatically generated by cffi-grovel.~%~
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 input-file :type "processed"))
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-defaults)))
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 output-defaults)
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 ,args)
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 fargnames)
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 c-lines)
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*))))