1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; grovel.lisp --- The CFFI Groveller.
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>
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:
18 ;;; The above copyright notice and this permission notice shall be
19 ;;; included in all copies or substantial portions of the Software.
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.
31 (in-package #:iolib-grovel
)
35 (defun trim-whitespace (strings)
36 (loop for s in strings
37 collect
(string-trim '(#\Space
#\Tab
) s
)))
40 "Coerce S to a string, making sure that it returns an extended string"
41 (map 'string
#'identity
(string s
)))
45 ;;; This warning is signalled when iolib-grovel can't find some macro.
46 ;;; Signalled by CONSTANT or CONSTANTENUM.
47 (define-condition missing-definition
(warning)
48 ((%name
:initarg
:name
:reader name-of
))
49 (:report
(lambda (condition stream
)
50 (format stream
"No definition for ~A"
51 (name-of condition
)))))
55 ;;; The header of the intermediate C file.
56 (defparameter *header
*
58 * This file has been automatically generated by iolib-grovel.
59 * Do not edit it by hand.
64 ;;; C code generated by iolib-grovel is inserted between the contents
65 ;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.
67 (defparameter *prologue
*
69 #include <grovel/common.h>
71 int main(int argc, char**argv) {
72 FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
73 fprintf(output, \";;;; This file has been automatically generated by \"
74 \"iolib-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
78 (defparameter *postscript
*
86 (defun unescape-for-c (text)
87 (with-output-to-string (result)
88 (loop for i below
(length text
)
89 for char
= (char text i
) do
90 (cond ((eql char
#\") (princ "\\\"" result
))
91 ((eql char
#\newline
) (princ "\\n" result
))
92 (t (princ char result
))))))
94 (defun c-format (out fmt
&rest args
)
95 (let ((text (unescape-for-c (format nil
"~?" fmt args
))))
96 (format out
"~& fprintf(output, \"~A\");~%" text
)))
98 (defun c-printf (out fmt
&rest args
)
100 (format out
"~A" (unescape-for-c (format nil item
)))))
101 (format out
"~& fprintf(output, \"")
104 (loop for arg in args do
107 (format out
");~%")))
109 ;;; TODO: handle packages in a better way. One way is to process each
110 ;;; grovel form as it is read (like we already do for wrapper
111 ;;; forms). This way in can expect *PACKAGE* to have sane values.
112 ;;; This would require that "header forms" come before any other
114 (defun c-print-symbol (out symbol
&optional no-package
)
116 (let ((package (symbol-package symbol
)))
118 ((eq (find-package '#:keyword
) package
) ":~(~A~)")
119 (no-package "~(~A~)")
120 ((eq (find-package '#:cl
) package
) "cl:~(~A~)")
124 (defun c-write (out form
&key recursive
)
127 (eq 'quote
(car form
)))
129 (c-write out
(cadr form
) :recursive t
))
132 (loop for subform in form
133 for first-p
= t then nil
134 unless first-p do
(c-format out
" ")
135 do
(c-write out subform
:recursive t
))
138 (c-print-symbol out form
)))
140 (c-format out
"~%")))
142 ;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
143 ;;; later, if necessary.
144 (defvar *auto-export
* nil
)
146 (defun c-export (out symbol
)
147 (when (and *auto-export
* (not (keywordp symbol
)))
148 (c-format out
"(cl:export '")
149 (c-print-symbol out symbol t
)
150 (c-format out
")~%")))
152 (defun c-section-header (out section-type section-symbol
)
153 (format out
"~% /* ~A section for ~S */~%"
157 (defun remove-suffix (string suffix
)
158 (let ((suffix-start (- (length string
) (length suffix
))))
159 (if (and (> suffix-start
0)
160 (string= string suffix
:start1 suffix-start
))
161 (subseq string
0 suffix-start
)
164 (defun strcat (&rest strings
)
165 (apply #'concatenate
'string strings
))
167 (defgeneric %process-grovel-form
(name out arguments
)
168 (:method
(name out arguments
)
169 (declare (ignore out arguments
))
170 (error "Unknown Grovel syntax: ~S" name
)))
172 (defun process-grovel-form (out form
)
173 (%process-grovel-form
(form-kind form
) out
(cdr form
)))
175 (defun form-kind (form)
176 ;; Using INTERN here instead of FIND-SYMBOL will result in less
177 ;; cryptic error messages when an undefined grovel/wrapper form is
179 (intern (symbol-name (car form
)) '#:iolib-grovel
))
181 (defvar *header-forms
* '(c include define flag typedef
))
183 (defun header-form-p (form)
184 (member (form-kind form
) *header-forms
*))
186 (defun generate-c-file (input-file output-defaults
)
187 (let ((c-file (make-pathname :type
"c" :defaults output-defaults
)))
188 (with-open-file (out c-file
:direction
:output
:if-exists
:supersede
)
189 (with-open-file (in input-file
:direction
:input
)
190 (flet ((read-forms (s)
192 (form (read s nil nil
) (read s nil nil
)))
193 ((null form
) (nreverse forms
))
197 (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead.")))
200 (setf *package
* (find-package (second f
)))
203 ;; flatten progn forms
204 (mapc #'process-form
(rest f
)))
205 (t (push f forms
)))))
206 (process-form form
)))))
207 (let* ((forms (read-forms in
))
208 (header-forms (remove-if-not #'header-form-p forms
))
209 (body-forms (remove-if #'header-form-p forms
)))
210 (write-string *header
* out
)
211 (dolist (form header-forms
)
212 (process-grovel-form out form
))
213 (write-string *prologue
* out
)
214 (dolist (form body-forms
)
215 (process-grovel-form out form
))
216 (write-string *postscript
* out
)))))
219 (defparameter *exe-extension
* #-windows nil
#+windows
"exe")
221 (defun exe-filename (defaults)
222 (let ((path (make-pathname :type
*exe-extension
*
223 :defaults defaults
)))
224 ;; It's necessary to prepend "./" to relative paths because some
225 ;; implementations of INVOKE use a shell.
226 (when (or (not (pathname-directory path
))
227 (eq :relative
(car (pathname-directory path
))))
228 (setf path
(make-pathname
229 :directory
(list* :relative
"."
230 (cdr (pathname-directory path
)))
234 (defun tmp-lisp-filename (defaults)
235 (make-pathname :name
(strcat (pathname-name defaults
) ".grovel-tmp")
236 :type
"lisp" :defaults defaults
))
238 (cffi:defcfun
"getenv" :string
243 #+(or cygwin
(not windows
)) "g++"
244 #+(and windows
(not cygwin
)) "c:/msys/1.0/bin/g++.exe")
246 (defparameter *cc-flags
*
248 (list "-Wno-write-strings")
250 #+darwin
(list "-I" "/opt/local/include/")
252 ;; ECL internal flags
253 #+ecl
(list c
::*cc-flags
*)))
255 ;;; FIXME: is there a better way to detect whether these flags
257 (defparameter *cpu-word-size-flags
*
258 #-
(or x86 x86-64 sparc sparc64
)
260 #+(or x86 x86-64 sparc sparc64
)
261 (ecase (cffi:foreign-type-size
:long
)
265 (defparameter *platform-library-flags
*
266 (list #+darwin
"-bundle"
270 (defun cc-compile-and-link (input-file output-file
&key library
)
272 `(,(or (getenv "CXX") *cxx
*)
273 ,@*cpu-word-size-flags
*
275 ;; add the cffi directory to the include path to make common.h visible
277 (directory-namestring
279 (asdf:system-definition-pathname
:iolib-grovel
))))
280 ,@(when library
*platform-library-flags
*)
281 "-o" ,(native-namestring output-file
)
282 ,(native-namestring input-file
))))
284 ;; if it's a library that may be used, remove it
285 ;; so we won't possibly be overwriting the code of any existing process
286 (ignore-some-conditions (file-error)
287 (delete-file output-file
)))
288 (apply #'invoke arglist
)))
290 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
291 ;;; *the extent of a given grovel file.
292 (defun process-grovel-file (input-file &optional
(output-defaults input-file
))
293 (with-standard-io-syntax
294 (let* ((c-file (generate-c-file input-file output-defaults
))
295 (exe-file (exe-filename c-file
))
296 (lisp-file (tmp-lisp-filename c-file
)))
297 (cc-compile-and-link c-file exe-file
)
298 (invoke exe-file
(native-namestring lisp-file
))
301 ;;; OUT is lexically bound to the output stream within BODY.
302 (defmacro define-grovel-syntax
(name lambda-list
&body body
)
303 (with-unique-names (name-var args
)
304 `(defmethod %process-grovel-form
((,name-var
(eql ',name
)) out
,args
)
305 (declare (ignorable out
))
306 (destructuring-bind ,lambda-list
,args
309 (define-grovel-syntax c
(body)
310 (format out
"~%~A~%" body
))
312 (define-grovel-syntax include
(&rest includes
)
313 (format out
"~{#include <~A>~%~}" includes
))
315 (define-grovel-syntax define
(name &optional value
)
316 (format out
"#define ~A~@[ ~A~]~%" name value
))
318 (define-grovel-syntax typedef
(base-type new-type
)
319 (format out
"typedef ~A ~A;~%" base-type new-type
))
321 ;;; Is this really needed?
322 (define-grovel-syntax ffi-typedef
(new-type base-type
)
323 (c-format out
"(cffi:defctype ~S ~S)~%" new-type base-type
))
325 (define-grovel-syntax flag
(&rest flags
)
326 (appendf *cc-flags
* (trim-whitespace flags
)))
328 (define-grovel-syntax cc-flags
(&rest flags
)
329 (appendf *cc-flags
* (trim-whitespace flags
)))
331 ;;; This form also has some "read time" effects. See GENERATE-C-FILE.
332 (define-grovel-syntax in-package
(name)
333 (c-format out
"(cl:in-package ~S)~%~%" (string* name
)))
335 (define-grovel-syntax ctype
(lisp-name c-name
)
336 (c-section-header out
"ctype" lisp-name
)
337 (format out
" CFFI_DEFCTYPE(~S, ~A);~%"
338 (string* lisp-name
) c-name
))
340 (defun docstring-to-c (docstring)
341 (if docstring
(format nil
"~S" docstring
) "NULL"))
343 (define-grovel-syntax constant
((lisp-name &rest c-names
) &key documentation optional
)
344 (c-section-header out
"constant" lisp-name
)
346 :for c-name
:in c-names
:do
347 (format out
"~A defined(~A)~%" (if (zerop i
) "#if" "#elif") c-name
)
348 (format out
" CFFI_DEFCONSTANT(~S, ~A, ~A);~%"
349 (string* lisp-name
) c-name
350 (docstring-to-c documentation
)))
352 (format out
"#else~% cffi_signal_missing_definition(output, ~S);~%"
353 (string* lisp-name
)))
354 (format out
"#endif~%"))
356 (define-grovel-syntax cunion
(union-lisp-name union-c-name
&rest slots
)
357 (let ((documentation (when (stringp (car slots
)) (pop slots
))))
358 (c-section-header out
"cunion" union-lisp-name
)
359 (format out
" CFFI_DEFCUNION_START(~S, ~A, ~A);~%"
360 (string* union-lisp-name
) union-c-name
361 (docstring-to-c documentation
))
363 (destructuring-bind (slot-lisp-name slot-c-name
&key type
(count 1))
367 (format out
" CFFI_DEFCUNION_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
368 union-c-name slot-c-name
369 (prin1-to-string slot-lisp-name
) (prin1-to-string type
)))
370 ((or integer symbol string
)
371 (format out
" CFFI_DEFCUNION_SLOT(~A, ~A, ~S, ~S, ~A);~%"
372 union-c-name slot-c-name
373 (prin1-to-string slot-lisp-name
) (prin1-to-string type
) count
)))))
374 (format out
" CFFI_DEFCUNION_END;~%")
375 (format out
" CFFI_DEFTYPEDEF(~S, ~S);~%"
376 (string* union-lisp-name
) (string* :union
))
377 (format out
" CFFI_DEFTYPESIZE(~S, ~A);~%"
378 (string* union-lisp-name
) union-c-name
)))
380 (defun make-from-pointer-function-name (type-name)
381 (symbolicate '#:make- type-name
'#:-from-pointer
))
383 ;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
384 ;;; cleaner way to do this. Unless I can find any advantage in doing
385 ;;; it this way I'll delete this soon. --luis
386 (define-grovel-syntax cstruct-and-class-item
(&rest arguments
)
387 (process-grovel-form out
(cons 'cstruct arguments
))
388 (destructuring-bind (struct-lisp-name struct-c-name
&rest slots
)
390 (declare (ignore struct-c-name
))
391 (let* ((slot-names (mapcar #'car slots
))
392 (reader-names (mapcar
395 (strcat (symbol-name struct-lisp-name
) "-"
396 (symbol-name slot-name
))))
398 (initarg-names (mapcar
400 (intern (symbol-name slot-name
) "KEYWORD"))
402 (slot-decoders (mapcar (lambda (slot)
408 (declare (ignore lisp-name c-name
))
409 (cond ((and (eq type
:char
) count
)
410 'cffi
:foreign-string-to-lisp
)
414 `(defclass ,struct-lisp-name
()
415 ,(mapcar (lambda (slot-name initarg-name reader-name
)
416 `(,slot-name
:initarg
,initarg-name
417 :reader
,reader-name
))
422 (make-from-pointer-function-name struct-lisp-name
))
424 ;; this function is then used as a constructor for this class.
425 `(defun ,make-function-name
(pointer)
426 (cffi:with-foreign-slots
427 (,slot-names pointer
,struct-lisp-name
)
428 (make-instance ',struct-lisp-name
429 ,@(loop for slot-name in slot-names
430 for initarg-name in initarg-names
431 for slot-decoder in slot-decoders
434 collect
`(,slot-decoder
,slot-name
)
435 else collect slot-name
))))))
436 (c-write out defclass-form
)
437 (c-write out make-defun-form
))))
439 (define-grovel-syntax cstruct
(struct-lisp-name struct-c-name
&rest slots
)
440 (let ((documentation (when (stringp (car slots
)) (pop slots
))))
441 (c-section-header out
"cstruct" struct-lisp-name
)
442 (format out
" CFFI_DEFCSTRUCT_START(~S, ~A, ~A);~%"
443 (string* struct-lisp-name
) struct-c-name
444 (docstring-to-c documentation
))
446 (destructuring-bind (slot-lisp-name slot-c-name
&key type
(count 1))
450 (format out
" CFFI_DEFCSTRUCT_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
451 struct-c-name slot-c-name
452 (prin1-to-string slot-lisp-name
) (prin1-to-string type
)))
453 ((or integer symbol string
)
454 (format out
" CFFI_DEFCSTRUCT_SLOT(~A, ~A, ~S, ~S, ~A);~%"
455 struct-c-name slot-c-name
456 (prin1-to-string slot-lisp-name
) (prin1-to-string type
) count
)))))
457 (format out
" CFFI_DEFCSTRUCT_END;~%")
458 (format out
" CFFI_DEFTYPEDEF(~S, ~S);~%"
459 (string* struct-lisp-name
) (string* :struct
))
460 (format out
" CFFI_DEFTYPESIZE(~S, ~A);~%"
461 (string* struct-lisp-name
) struct-c-name
)))
463 (defun foreign-name-to-symbol (s)
464 (intern (substitute #\-
#\_
(string-upcase s
))))
466 (defun choose-lisp-and-foreign-names (string-or-list)
467 (etypecase string-or-list
468 (string (values string-or-list
(foreign-name-to-symbol string-or-list
)))
469 (list (destructuring-bind (fname lname
&rest args
) string-or-list
470 (declare (ignore args
))
471 (assert (and (stringp fname
) (symbolp lname
)))
472 (values fname lname
)))))
474 (define-grovel-syntax cenum
(name &rest enum-list
)
475 (let ((documentation (when (stringp (car enum-list
)) (pop enum-list
))))
476 (destructuring-bind (name &key
(base-type :int
) define-constants
)
478 (c-section-header out
"cenum" name
)
479 (format out
" CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
480 (string* name
) (prin1-to-string base-type
)
481 (docstring-to-c documentation
))
482 (dolist (enum enum-list
)
483 (destructuring-bind (lisp-name c-name
&key documentation
)
485 (check-type lisp-name keyword
)
486 (format out
" CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
487 (prin1-to-string lisp-name
) c-name
488 (docstring-to-c documentation
))))
489 (format out
" CFFI_DEFCENUM_END;~%")
490 (when define-constants
491 (define-constants-from-enum out enum-list
)))))
493 (define-grovel-syntax constantenum
(name &rest enum-list
)
494 (let ((documentation (when (stringp (car enum-list
)) (pop enum-list
))))
495 (destructuring-bind (name &key
(base-type :int
) define-constants
)
497 (c-section-header out
"constantenum" name
)
498 (format out
" CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
499 (string* name
) (prin1-to-string base-type
)
500 (docstring-to-c documentation
))
501 (dolist (enum enum-list
)
502 (destructuring-bind (lisp-name c-name
&key documentation optional
)
504 (check-type lisp-name keyword
)
506 (format out
"#if defined(~A)~%" c-name
))
507 (format out
" CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
508 (prin1-to-string lisp-name
) c-name
509 (docstring-to-c documentation
))
511 (format out
"#endif~%"))))
512 (format out
" CFFI_DEFCENUM_END;~%")
513 (when define-constants
514 (define-constants-from-enum out enum-list
)))))
516 (defun define-constants-from-enum (out enum-list
)
517 (dolist (enum enum-list
)
518 (destructuring-bind (lisp-name c-name
&key documentation optional
)
521 out
`(constant (,lisp-name
,c-name
)
522 ,@(if documentation
(list :documentation t
))
523 ,@(if optional
(list :optional t
)))))))
526 ;;;# Wrapper Generation
528 ;;; Here we generate a C file from a s-exp specification but instead
529 ;;; of compiling and running it, we compile it as a shared library
530 ;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
532 ;;; Useful to get at macro functionality, errno, system calls,
533 ;;; functions that handle structures by value, etc...
535 ;;; Matching CFFI bindings are generated along with said C file.
537 (defun process-wrapper-form (out form
)
538 (%process-wrapper-form
(form-kind form
) out
(cdr form
)))
540 ;;; The various operators push Lisp forms onto this list which will be
541 ;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
542 (defvar *lisp-forms
*)
544 (defun generate-c-lib-file (input-file output-defaults
)
545 (let ((*lisp-forms
* nil
)
546 (c-file (make-pathname :type
"c" :defaults output-defaults
)))
547 (with-open-file (out c-file
:direction
:output
:if-exists
:supersede
)
548 (with-open-file (in input-file
:direction
:input
)
549 (write-string *header
* out
)
550 (loop for form
= (read in nil nil
) while form
551 do
(process-wrapper-form out form
))))
552 (values c-file
(nreverse *lisp-forms
*))))
554 (defun lib-filename (defaults)
555 (make-pathname :type
(subseq (cffi::default-library-suffix
) 1)
558 (defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults
)
559 (let ((lisp-file (tmp-lisp-filename output-defaults
)))
560 (with-open-file (out lisp-file
:direction
:output
:if-exists
:supersede
)
561 (format out
";;;; This file was automatically generated by iolib-grovel.~%~
562 ;;;; Do not edit by hand.~%")
563 (let ((*package
* (find-package '#:cl
))
565 (let ((*package
* (find-package :keyword
))
567 (read-from-string lib-soname
))))
569 (cffi:define-foreign-library
571 :type
:grovel-wrapper
572 :search-path
,(directory-namestring lib-file
))
573 (t ,(namestring (lib-filename lib-soname
))))
574 (cffi:use-foreign-library
,named-library-name
))
577 (dolist (form lisp-forms
)
582 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
583 ;;; *the extent of a given wrapper file.
584 (defun process-wrapper-file (input-file output-defaults lib-soname
)
585 (with-standard-io-syntax
587 (lib-filename (make-pathname :name lib-soname
588 :defaults output-defaults
))))
589 (multiple-value-bind (c-file lisp-forms
)
590 (generate-c-lib-file input-file output-defaults
)
591 (cc-compile-and-link c-file lib-file
:library t
)
592 ;; FIXME: hardcoded library path.
593 (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults
)
596 (defgeneric %process-wrapper-form
(name out arguments
)
597 (:method
(name out arguments
)
598 (declare (ignore out arguments
))
599 (error "Unknown Grovel syntax: ~S" name
)))
601 ;;; OUT is lexically bound to the output stream within BODY.
602 (defmacro define-wrapper-syntax
(name lambda-list
&body body
)
603 (with-unique-names (name-var args
)
604 `(defmethod %process-wrapper-form
((,name-var
(eql ',name
)) out
,args
)
605 (declare (ignorable out
))
606 (destructuring-bind ,lambda-list
,args
609 (define-wrapper-syntax progn
(&rest forms
)
611 (process-wrapper-form out form
)))
613 (define-wrapper-syntax in-package
(name)
614 (setq *package
* (find-package name
))
615 (push `(in-package ,name
) *lisp-forms
*))
617 (define-wrapper-syntax c
(&rest strings
)
618 (dolist (string strings
)
619 (write-line string out
)))
621 (define-wrapper-syntax flag
(&rest flags
)
622 (appendf *cc-flags
* (trim-whitespace flags
)))
624 (define-wrapper-syntax proclaim
(&rest proclamations
)
625 (push `(proclaim ,@proclamations
) *lisp-forms
*))
627 (define-wrapper-syntax declaim
(&rest declamations
)
628 (push `(declaim ,@declamations
) *lisp-forms
*))
630 (define-wrapper-syntax define
(name &optional value
)
631 (format out
"#define ~A~@[ ~A~]~%" name value
))
633 (define-wrapper-syntax include
(&rest includes
)
634 (format out
"~{#include <~A>~%~}" includes
))
636 ;;; FIXME: this function is not complete. Should probably follow
637 ;;; typedefs? Should definitely understand pointer types.
638 (defun c-type-name (typespec)
639 (let ((spec (ensure-list typespec
)))
640 (if (stringp (car spec
))
643 ((:uchar
:unsigned-char
) "unsigned char")
644 ((:unsigned-short
:ushort
) "unsigned short")
645 ((:unsigned-int
:uint
) "unsigned int")
646 ((:unsigned-long
:ulong
) "unsigned long")
647 ((:long-long
:llong
) "long long")
648 ((:unsigned-long-long
:ullong
) "unsigned long long")
651 (t (cffi::foreign-name
(car spec
) nil
))))))
653 (defun cffi-type (typespec)
654 (if (and (listp typespec
) (stringp (car typespec
)))
658 (define-wrapper-syntax defwrapper
(name-and-options rettype
&rest args
)
659 (multiple-value-bind (lisp-name foreign-name options
)
660 (cffi::parse-name-and-options name-and-options
)
661 (let* ((foreign-name-wrap (strcat foreign-name
"_cffi_wrap"))
662 (fargs (mapcar (lambda (arg)
663 (list (c-type-name (second arg
))
664 (cffi::foreign-name
(first arg
) nil
)))
666 (fargnames (mapcar #'second fargs
)))
668 (format out
"~A ~A" (c-type-name rettype
) foreign-name-wrap
)
669 (format out
"(~{~{~A ~A~}~^, ~})~%" fargs
)
670 (format out
"{~% return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames
)
672 (push `(cffi:defcfun
(,foreign-name-wrap
,lisp-name
,@options
)
674 ,@(mapcar (lambda (arg)
675 (list (cffi::lisp-name
(first arg
) nil
)
676 (cffi-type (second arg
))))
680 (define-wrapper-syntax defwrapper
* (name-and-options rettype args
&rest c-lines
)
682 (multiple-value-bind (lisp-name foreign-name options
)
683 (cffi::parse-name-and-options name-and-options
)
684 (let ((foreign-name-wrap (strcat foreign-name
"_cffi_wrap"))
685 (fargs (mapcar (lambda (arg)
686 (list (c-type-name (second arg
))
687 (cffi::foreign-name
(first arg
) nil
)))
689 (format out
"~A ~A" (c-type-name rettype
)
691 (format out
"(~{~{~A ~A~}~^, ~})~%" fargs
)
692 (format out
"{~%~{ ~A~%~}}~%~%" c-lines
)
694 (push `(cffi:defcfun
(,foreign-name-wrap
,lisp-name
,@options
)
696 ,@(mapcar (lambda (arg)
697 (list (cffi::lisp-name
(first arg
) nil
)
698 (cffi-type (second arg
))))