grovel.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[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*)))) |