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) {
73 FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
74 fprintf(output, \";;;; This file has been automatically generated by \"
75 \"iolib-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
79 (defparameter *postscript
*
87 (defun unescape-for-c (text)
88 (with-output-to-string (result)
89 (loop for i below
(length text
)
90 for char
= (char text i
) do
91 (cond ((eql char
#\") (princ "\\\"" result
))
92 ((eql char
#\newline
) (princ "\\n" result
))
93 (t (princ char result
))))))
95 (defun c-format (out fmt
&rest args
)
96 (let ((text (unescape-for-c (format nil
"~?" fmt args
))))
97 (format out
"~& fputs(\"~A\", output);~%" text
)))
99 (defun c-printf (out fmt
&rest args
)
101 (format out
"~A" (unescape-for-c (format nil item
)))))
102 (format out
"~& fprintf(output, \"")
105 (loop for arg in args do
108 (format out
");~%")))
110 ;;; TODO: handle packages in a better way. One way is to process each
111 ;;; grovel form as it is read (like we already do for wrapper
112 ;;; forms). This way in can expect *PACKAGE* to have sane values.
113 ;;; This would require that "header forms" come before any other
115 (defun c-print-symbol (out symbol
&optional no-package
)
117 (let ((package (symbol-package symbol
)))
119 ((eq (find-package '#:keyword
) package
) ":~(~A~)")
120 (no-package "~(~A~)")
121 ((eq (find-package '#:cl
) package
) "cl:~(~A~)")
125 (defun c-write (out form
&key recursive
)
128 (eq 'quote
(car form
)))
130 (c-write out
(cadr form
) :recursive t
))
133 (loop for subform in form
134 for first-p
= t then nil
135 unless first-p do
(c-format out
" ")
136 do
(c-write out subform
:recursive t
))
139 (c-print-symbol out form
)))
141 (c-format out
"~%")))
143 ;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
144 ;;; later, if necessary.
145 (defvar *auto-export
* nil
)
147 (defun c-export (out symbol
)
148 (when (and *auto-export
* (not (keywordp symbol
)))
149 (c-format out
"(cl:export '")
150 (c-print-symbol out symbol t
)
151 (c-format out
")~%")))
153 (defun c-section-header (out section-type section-symbol
)
154 (format out
"~% /* ~A section for ~S */~%"
158 (defun remove-suffix (string suffix
)
159 (let ((suffix-start (- (length string
) (length suffix
))))
160 (if (and (> suffix-start
0)
161 (string= string suffix
:start1 suffix-start
))
162 (subseq string
0 suffix-start
)
165 (defun strcat (&rest strings
)
166 (apply #'concatenate
'string strings
))
168 (defgeneric %process-grovel-form
(name out arguments
)
169 (:method
(name out arguments
)
170 (declare (ignore out arguments
))
171 (error "Unknown Grovel syntax: ~S" name
)))
173 (defun process-grovel-form (out form
)
174 (%process-grovel-form
(form-kind form
) out
(cdr form
)))
176 (defun form-kind (form)
177 ;; Using INTERN here instead of FIND-SYMBOL will result in less
178 ;; cryptic error messages when an undefined grovel/wrapper form is
180 (intern (symbol-name (car form
)) '#:iolib-grovel
))
182 (defvar *header-forms
* '(c include define flag typedef
))
184 (defun header-form-p (form)
185 (member (form-kind form
) *header-forms
*))
187 (defun generate-c-file (input-file output-defaults
)
188 (let ((c-file (make-pathname :type
"c" :defaults output-defaults
)))
189 (with-open-file (out c-file
:direction
:output
:if-exists
:supersede
)
190 (with-open-file (in input-file
:direction
:input
)
191 (flet ((read-forms (s)
193 (form (read s nil nil
) (read s nil nil
)))
194 ((null form
) (nreverse forms
))
198 (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead.")))
201 (setf *package
* (find-package (second f
)))
204 ;; flatten progn forms
205 (mapc #'process-form
(rest f
)))
206 (t (push f forms
)))))
207 (process-form form
)))))
208 (let* ((forms (read-forms in
))
209 (header-forms (remove-if-not #'header-form-p forms
))
210 (body-forms (remove-if #'header-form-p forms
)))
211 (write-string *header
* out
)
212 (dolist (form header-forms
)
213 (process-grovel-form out form
))
214 (write-string *prologue
* out
)
215 (dolist (form body-forms
)
216 (process-grovel-form out form
))
217 (write-string *postscript
* out
)))))
220 (defparameter *exe-extension
* #-windows nil
#+windows
"exe")
222 (defun exe-filename (defaults)
223 (let ((path (make-pathname :type
*exe-extension
*
224 :defaults defaults
)))
225 ;; It's necessary to prepend "./" to relative paths because some
226 ;; implementations of INVOKE use a shell.
227 (when (or (not (pathname-directory path
))
228 (eq :relative
(car (pathname-directory path
))))
229 (setf path
(make-pathname
230 :directory
(list* :relative
"."
231 (cdr (pathname-directory path
)))
235 (defun tmp-lisp-filename (defaults)
236 (make-pathname :name
(strcat (pathname-name defaults
) ".grovel-tmp")
237 :type
"lisp" :defaults defaults
))
239 (cffi:defcfun
"getenv" :string
244 #+(or cygwin
(not windows
)) "g++"
245 #+(and windows
(not cygwin
)) "c:/msys/1.0/bin/g++.exe")
247 (defparameter *cc-flags
*
249 (list "-Wno-write-strings")
251 #+darwin
(list "-I" "/opt/local/include/")
253 ;; ECL internal flags
254 #+ecl
(list c
::*cc-flags
*)
255 ;; FreeBSD non-base header files
256 #+freebsd
(list "-I" "/usr/local/include/")))
258 ;;; FIXME: is there a better way to detect whether these flags
260 (defparameter *cpu-word-size-flags
*
261 #-
(or arm x86 x86-64 sparc sparc64
)
265 #+(or x86 x86-64 sparc sparc64
)
266 (ecase (cffi:foreign-type-size
:pointer
)
270 (defparameter *platform-library-flags
*
271 (list #+darwin
"-bundle"
275 (defun cc-compile-and-link (input-file output-file
&key library
)
277 `(,(or (getenv "CXX") *cxx
*)
278 ,@*cpu-word-size-flags
*
280 ;; add the cffi directory to the include path to make common.h visible
282 (directory-namestring
284 (asdf:system-definition-pathname
:iolib-grovel
))))
285 ,@(when library
*platform-library-flags
*)
286 "-o" ,(native-namestring output-file
)
287 ,(native-namestring input-file
))))
289 ;; if it's a library that may be used, remove it
290 ;; so we won't possibly be overwriting the code of any existing process
291 (ignore-some-conditions (file-error)
292 (delete-file output-file
)))
293 (apply #'invoke arglist
)))
295 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
296 ;;; *the extent of a given grovel file.
297 (defun process-grovel-file (input-file &optional
(output-defaults input-file
))
298 (with-standard-io-syntax
299 (let* ((c-file (generate-c-file input-file output-defaults
))
300 (exe-file (exe-filename c-file
))
301 (lisp-file (tmp-lisp-filename c-file
)))
302 (cc-compile-and-link c-file exe-file
)
303 (invoke exe-file
(native-namestring lisp-file
))
306 ;;; OUT is lexically bound to the output stream within BODY.
307 (defmacro define-grovel-syntax
(name lambda-list
&body body
)
308 (with-unique-names (name-var args
)
309 `(defmethod %process-grovel-form
((,name-var
(eql ',name
)) out
,args
)
310 (declare (ignorable out
))
311 (destructuring-bind ,lambda-list
,args
314 (define-grovel-syntax c
(body)
315 (format out
"~%~A~%" body
))
317 (define-grovel-syntax include
(&rest includes
)
318 (format out
"~{#include <~A>~%~}" includes
))
320 (define-grovel-syntax define
(name &optional value
)
321 (format out
"#define ~A~@[ ~A~]~%" name value
))
323 (define-grovel-syntax typedef
(base-type new-type
)
324 (format out
"typedef ~A ~A;~%" base-type new-type
))
326 ;;; Is this really needed?
327 (define-grovel-syntax ffi-typedef
(new-type base-type
)
328 (c-format out
"(cffi:defctype ~S ~S)~%" new-type base-type
))
330 (define-grovel-syntax flag
(&rest flags
)
331 (appendf *cc-flags
* (trim-whitespace flags
)))
333 (define-grovel-syntax cc-flags
(&rest flags
)
334 (appendf *cc-flags
* (trim-whitespace flags
)))
336 ;;; This form also has some "read time" effects. See GENERATE-C-FILE.
337 (define-grovel-syntax in-package
(name)
338 (c-format out
"(cl:in-package ~S)~%~%" (string* name
)))
340 (define-grovel-syntax ctype
(lisp-name c-name
)
341 (c-section-header out
"ctype" lisp-name
)
342 (format out
" CFFI_DEFCTYPE(~S, ~A);~%"
343 (string* lisp-name
) c-name
))
345 (defun docstring-to-c (docstring)
346 (if docstring
(format nil
"~S" docstring
) "NULL"))
348 (define-grovel-syntax constant
((lisp-name &rest c-names
) &key documentation optional
)
349 (c-section-header out
"constant" lisp-name
)
351 :for c-name
:in c-names
:do
352 (format out
"~A defined(~A)~%" (if (zerop i
) "#if" "#elif") c-name
)
353 (format out
" CFFI_DEFCONSTANT(~S, ~A, ~A);~%"
354 (string* lisp-name
) c-name
355 (docstring-to-c documentation
)))
357 (format out
"#else~% cffi_signal_missing_definition(output, ~S);~%"
358 (string* lisp-name
)))
359 (format out
"#endif~%"))
361 (define-grovel-syntax cunion
(union-lisp-name union-c-name
&rest slots
)
362 (let ((documentation (when (stringp (car slots
)) (pop slots
))))
363 (c-section-header out
"cunion" union-lisp-name
)
364 (format out
" CFFI_DEFCUNION_START(~S, ~A, ~A);~%"
365 (string* union-lisp-name
) union-c-name
366 (docstring-to-c documentation
))
368 (destructuring-bind (slot-lisp-name slot-c-name
&key type
(count 1))
372 (format out
" CFFI_DEFCUNION_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
373 union-c-name slot-c-name
374 (prin1-to-string slot-lisp-name
) (prin1-to-string type
)))
375 ((or integer symbol string
)
376 (format out
" CFFI_DEFCUNION_SLOT(~A, ~A, ~S, ~S, ~A);~%"
377 union-c-name slot-c-name
378 (prin1-to-string slot-lisp-name
) (prin1-to-string type
) count
)))))
379 (format out
" CFFI_DEFCUNION_END;~%")
380 (format out
" CFFI_DEFTYPEDEF(~S, ~S);~%"
381 (string* union-lisp-name
) (string* :union
))
382 (format out
" CFFI_DEFTYPESIZE(~S, ~A);~%"
383 (string* union-lisp-name
) union-c-name
)))
385 (defun make-from-pointer-function-name (type-name)
386 (symbolicate '#:make- type-name
'#:-from-pointer
))
388 ;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
389 ;;; cleaner way to do this. Unless I can find any advantage in doing
390 ;;; it this way I'll delete this soon. --luis
391 (define-grovel-syntax cstruct-and-class-item
(&rest arguments
)
392 (process-grovel-form out
(cons 'cstruct arguments
))
393 (destructuring-bind (struct-lisp-name struct-c-name
&rest slots
)
395 (declare (ignore struct-c-name
))
396 (let* ((slot-names (mapcar #'car slots
))
397 (reader-names (mapcar
400 (strcat (symbol-name struct-lisp-name
) "-"
401 (symbol-name slot-name
))))
403 (initarg-names (mapcar
405 (intern (symbol-name slot-name
) "KEYWORD"))
407 (slot-decoders (mapcar (lambda (slot)
413 (declare (ignore lisp-name c-name
))
414 (cond ((and (eq type
:char
) count
)
415 'cffi
:foreign-string-to-lisp
)
419 `(defclass ,struct-lisp-name
()
420 ,(mapcar (lambda (slot-name initarg-name reader-name
)
421 `(,slot-name
:initarg
,initarg-name
422 :reader
,reader-name
))
427 (make-from-pointer-function-name struct-lisp-name
))
429 ;; this function is then used as a constructor for this class.
430 `(defun ,make-function-name
(pointer)
431 (cffi:with-foreign-slots
432 (,slot-names pointer
,struct-lisp-name
)
433 (make-instance ',struct-lisp-name
434 ,@(loop for slot-name in slot-names
435 for initarg-name in initarg-names
436 for slot-decoder in slot-decoders
439 collect
`(,slot-decoder
,slot-name
)
440 else collect slot-name
))))))
441 (c-write out defclass-form
)
442 (c-write out make-defun-form
))))
444 (define-grovel-syntax cstruct
(struct-lisp-name struct-c-name
&rest slots
)
445 (let ((documentation (when (stringp (car slots
)) (pop slots
))))
446 (c-section-header out
"cstruct" struct-lisp-name
)
447 (format out
" CFFI_DEFCSTRUCT_START(~S, ~A, ~A);~%"
448 (string* struct-lisp-name
) struct-c-name
449 (docstring-to-c documentation
))
451 (destructuring-bind (slot-lisp-name slot-c-name
&key type
(count 1))
455 (format out
" CFFI_DEFCSTRUCT_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
456 struct-c-name slot-c-name
457 (prin1-to-string slot-lisp-name
) (prin1-to-string type
)))
458 ((or integer symbol string
)
459 (format out
" CFFI_DEFCSTRUCT_SLOT(~A, ~A, ~S, ~S, ~A);~%"
460 struct-c-name slot-c-name
461 (prin1-to-string slot-lisp-name
) (prin1-to-string type
) count
)))))
462 (format out
" CFFI_DEFCSTRUCT_END;~%")
463 (format out
" CFFI_DEFTYPEDEF(~S, ~S);~%"
464 (string* struct-lisp-name
) (string* :struct
))
465 (format out
" CFFI_DEFTYPESIZE(~S, ~A);~%"
466 (string* struct-lisp-name
) struct-c-name
)))
468 (defun foreign-name-to-symbol (s)
469 (intern (substitute #\-
#\_
(string-upcase s
))))
471 (defun choose-lisp-and-foreign-names (string-or-list)
472 (etypecase string-or-list
473 (string (values string-or-list
(foreign-name-to-symbol string-or-list
)))
474 (list (destructuring-bind (fname lname
&rest args
) string-or-list
475 (declare (ignore args
))
476 (assert (and (stringp fname
) (symbolp lname
)))
477 (values fname lname
)))))
479 (define-grovel-syntax cenum
(name &rest enum-list
)
480 (let ((documentation (when (stringp (car enum-list
)) (pop enum-list
))))
481 (destructuring-bind (name &key
(base-type :int
) define-constants
)
483 (c-section-header out
"cenum" name
)
484 (format out
" CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
485 (string* name
) (prin1-to-string base-type
)
486 (docstring-to-c documentation
))
487 (dolist (enum enum-list
)
488 (destructuring-bind (lisp-name c-name
&key documentation
)
490 (check-type lisp-name keyword
)
491 (format out
" CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
492 (prin1-to-string lisp-name
) c-name
493 (docstring-to-c documentation
))))
494 (format out
" CFFI_DEFCENUM_END;~%")
495 (when define-constants
496 (define-constants-from-enum out enum-list
)))))
498 (define-grovel-syntax constantenum
(name &rest enum-list
)
499 (let ((documentation (when (stringp (car enum-list
)) (pop enum-list
))))
500 (destructuring-bind (name &key
(base-type :int
) define-constants
)
502 (c-section-header out
"constantenum" name
)
503 (format out
" CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
504 (string* name
) (prin1-to-string base-type
)
505 (docstring-to-c documentation
))
506 (dolist (enum enum-list
)
507 (destructuring-bind (lisp-name c-name
&key documentation optional
)
509 (check-type lisp-name keyword
)
511 (format out
"#if defined(~A)~%" c-name
))
512 (format out
" CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
513 (prin1-to-string lisp-name
) c-name
514 (docstring-to-c documentation
))
516 (format out
"#endif~%"))))
517 (format out
" CFFI_DEFCENUM_END;~%")
518 (when define-constants
519 (define-constants-from-enum out enum-list
)))))
521 (defun define-constants-from-enum (out enum-list
)
522 (dolist (enum enum-list
)
523 (destructuring-bind (lisp-name c-name
&key documentation optional
)
526 out
`(constant (,lisp-name
,c-name
)
527 ,@(if documentation
(list :documentation t
))
528 ,@(if optional
(list :optional t
)))))))
531 ;;;# Wrapper Generation
533 ;;; Here we generate a C file from a s-exp specification but instead
534 ;;; of compiling and running it, we compile it as a shared library
535 ;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
537 ;;; Useful to get at macro functionality, errno, system calls,
538 ;;; functions that handle structures by value, etc...
540 ;;; Matching CFFI bindings are generated along with said C file.
542 (defun process-wrapper-form (out form
)
543 (%process-wrapper-form
(form-kind form
) out
(cdr form
)))
545 ;;; The various operators push Lisp forms onto this list which will be
546 ;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
547 (defvar *lisp-forms
*)
549 (defun generate-c-lib-file (input-file output-defaults
)
550 (let ((*lisp-forms
* nil
)
551 (c-file (make-pathname :type
"c" :defaults output-defaults
)))
552 (with-open-file (out c-file
:direction
:output
:if-exists
:supersede
)
553 (with-open-file (in input-file
:direction
:input
)
554 (write-string *header
* out
)
555 (loop for form
= (read in nil nil
) while form
556 do
(process-wrapper-form out form
))))
557 (values c-file
(nreverse *lisp-forms
*))))
559 (defun lib-filename (defaults)
560 (make-pathname :type
(subseq (cffi::default-library-suffix
) 1)
563 (defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults
)
564 (let ((lisp-file (tmp-lisp-filename output-defaults
)))
565 (with-open-file (out lisp-file
:direction
:output
:if-exists
:supersede
)
566 (format out
";;;; This file was automatically generated by iolib-grovel.~%~
567 ;;;; Do not edit by hand.~%")
568 (let ((*package
* (find-package '#:cl
))
570 (let ((*package
* (find-package :keyword
))
572 (read-from-string lib-soname
))))
574 (cffi:define-foreign-library
576 :type
:grovel-wrapper
577 :search-path
,(directory-namestring lib-file
))
578 (t ,(namestring (lib-filename lib-soname
))))
579 (cffi:use-foreign-library
,named-library-name
))
582 (dolist (form lisp-forms
)
587 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
588 ;;; *the extent of a given wrapper file.
589 (defun process-wrapper-file (input-file output-defaults lib-soname
)
590 (with-standard-io-syntax
592 (lib-filename (make-pathname :name lib-soname
593 :defaults output-defaults
))))
594 (multiple-value-bind (c-file lisp-forms
)
595 (generate-c-lib-file input-file output-defaults
)
596 (cc-compile-and-link c-file lib-file
:library t
)
597 ;; FIXME: hardcoded library path.
598 (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults
)
601 (defgeneric %process-wrapper-form
(name out arguments
)
602 (:method
(name out arguments
)
603 (declare (ignore out arguments
))
604 (error "Unknown Grovel syntax: ~S" name
)))
606 ;;; OUT is lexically bound to the output stream within BODY.
607 (defmacro define-wrapper-syntax
(name lambda-list
&body body
)
608 (with-unique-names (name-var args
)
609 `(defmethod %process-wrapper-form
((,name-var
(eql ',name
)) out
,args
)
610 (declare (ignorable out
))
611 (destructuring-bind ,lambda-list
,args
614 (define-wrapper-syntax progn
(&rest forms
)
616 (process-wrapper-form out form
)))
618 (define-wrapper-syntax in-package
(name)
619 (setq *package
* (find-package name
))
620 (push `(in-package ,name
) *lisp-forms
*))
622 (define-wrapper-syntax c
(&rest strings
)
623 (dolist (string strings
)
624 (write-line string out
)))
626 (define-wrapper-syntax flag
(&rest flags
)
627 (appendf *cc-flags
* (trim-whitespace flags
)))
629 (define-wrapper-syntax proclaim
(&rest proclamations
)
630 (push `(proclaim ,@proclamations
) *lisp-forms
*))
632 (define-wrapper-syntax declaim
(&rest declamations
)
633 (push `(declaim ,@declamations
) *lisp-forms
*))
635 (define-wrapper-syntax define
(name &optional value
)
636 (format out
"#define ~A~@[ ~A~]~%" name value
))
638 (define-wrapper-syntax include
(&rest includes
)
639 (format out
"~{#include <~A>~%~}" includes
))
641 ;;; FIXME: this function is not complete. Should probably follow
642 ;;; typedefs? Should definitely understand pointer types.
643 (defun c-type-name (typespec)
644 (let ((spec (ensure-list typespec
)))
645 (if (stringp (car spec
))
648 ((:uchar
:unsigned-char
) "unsigned char")
649 ((:unsigned-short
:ushort
) "unsigned short")
650 ((:unsigned-int
:uint
) "unsigned int")
651 ((:unsigned-long
:ulong
) "unsigned long")
652 ((:long-long
:llong
) "long long")
653 ((:unsigned-long-long
:ullong
) "unsigned long long")
656 (t (cffi::foreign-name
(car spec
) nil
))))))
658 (defun cffi-type (typespec)
659 (if (and (listp typespec
) (stringp (car typespec
)))
663 (define-wrapper-syntax defwrapper
(name-and-options rettype
&rest args
)
664 (multiple-value-bind (lisp-name foreign-name options
)
665 (cffi::parse-name-and-options name-and-options
)
666 (let* ((foreign-name-wrap (strcat foreign-name
"_cffi_wrap"))
667 (fargs (mapcar (lambda (arg)
668 (list (c-type-name (second arg
))
669 (cffi::foreign-name
(first arg
) nil
)))
671 (fargnames (mapcar #'second fargs
)))
673 (format out
"~A ~A" (c-type-name rettype
) foreign-name-wrap
)
674 (format out
"(~{~{~A ~A~}~^, ~})~%" fargs
)
675 (format out
"{~% return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames
)
677 (push `(cffi:defcfun
(,foreign-name-wrap
,lisp-name
,@options
)
679 ,@(mapcar (lambda (arg)
680 (list (cffi::lisp-name
(first arg
) nil
)
681 (cffi-type (second arg
))))
685 (define-wrapper-syntax defwrapper
* (name-and-options rettype args
&rest c-lines
)
687 (multiple-value-bind (lisp-name foreign-name options
)
688 (cffi::parse-name-and-options name-and-options
)
689 (let ((foreign-name-wrap (strcat foreign-name
"_cffi_wrap"))
690 (fargs (mapcar (lambda (arg)
691 (list (c-type-name (second arg
))
692 (cffi::foreign-name
(first arg
) nil
)))
694 (format out
"~A ~A" (c-type-name rettype
)
696 (format out
"(~{~{~A ~A~}~^, ~})~%" fargs
)
697 (format out
"{~%~{ ~A~%~}}~%~%" c-lines
)
699 (push `(cffi:defcfun
(,foreign-name-wrap
,lisp-name
,@options
)
701 ,@(mapcar (lambda (arg)
702 (list (cffi::lisp-name
(first arg
) nil
)
703 (cffi-type (second arg
))))