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;;;# Utils 34 35(defun trim-whitespace (strings) 36 (loop for s in strings 37 for trim = (string-trim '(#\Space #\Tab #\Newline) s) 38 unless (string= "" trim) collect trim)) 39 40;;;# Error Conditions 41 42(define-condition grovel-error (simple-error) ()) 43 44(defun grovel-error (format-control &rest format-arguments) 45 (error 'grovel-error 46 :format-control format-control 47 :format-arguments format-arguments)) 48 49;;; This warning is signalled when cffi-grovel can't find some macro. 50;;; Signalled by CONSTANT or CONSTANTENUM. 51(define-condition missing-definition (warning) 52 ((%name :initarg :name :reader name-of)) 53 (:report (lambda (condition stream) 54 (format stream "No definition for ~A" 55 (name-of condition))))) 56 57;;;# Grovelling 58 59;;; The header of the intermediate C file. 60(defparameter *header* 61 "/* 62 * This file has been automatically generated by cffi-grovel. 63 * Do not edit it by hand. 64 */ 65 66") 67 68;;; C code generated by cffi-grovel is inserted between the contents 69;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body. 70 71(defparameter *prologue* 72 " 73#include <grovel/common.h> 74 75int main(int argc, char**argv) { 76 int autotype_tmp; 77 FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout; 78 fprintf(output, \";;;; This file has been automatically generated by \" 79 \"cffi-grovel.\\n;;;; Do not edit it by hand.\\n\\n\"); 80") 81 82(defparameter *postscript* 83 " 84 if (output != stdout) 85 fclose(output); 86 return 0; 87} 88") 89 90(defun unescape-for-c (text) 91 (with-output-to-string (result) 92 (loop for i below (length text) 93 for char = (char text i) do 94 (cond ((eql char #\") (princ "\\\"" result)) 95 ((eql char #\newline) (princ "\\n" result)) 96 (t (princ char result)))))) 97 98(defun c-format (out fmt &rest args) 99 (let ((text (unescape-for-c (format nil "~?" fmt args)))) 100 (format out "~& fputs(\"~A\", output);~%" text))) 101 102(defun c-printf (out fmt &rest args) 103 (flet ((item (item) 104 (format out "~A" (unescape-for-c (format nil item))))) 105 (format out "~& fprintf(output, \"") 106 (item fmt) 107 (format out "\"") 108 (loop for arg in args do 109 (format out ", ") 110 (item arg)) 111 (format out ");~%"))) 112 113(defun c-print-integer-constant (out arg &optional foreign-type) 114 (let ((foreign-type (or foreign-type :int))) 115 (c-format out "#.(cffi-grovel::convert-intmax-constant ") 116 (format out "~& fprintf(output, \"%\"PRIiMAX, (intmax_t)~A);~%" 117 arg) 118 (c-format out " ") 119 (c-write out `(quote ,foreign-type)) 120 (c-format out ")"))) 121 122;;; TODO: handle packages in a better way. One way is to process each 123;;; grovel form as it is read (like we already do for wrapper 124;;; forms). This way in can expect *PACKAGE* to have sane values. 125;;; This would require that "header forms" come before any other 126;;; forms. 127(defun c-print-symbol (out symbol &optional no-package) 128 (c-format out 129 (let ((package (symbol-package symbol))) 130 (cond 131 ((eq (find-package '#:keyword) package) ":~(~A~)") 132 (no-package "~(~A~)") 133 ((eq (find-package '#:cl) package) "cl:~(~A~)") 134 (t "~(~A~)"))) 135 symbol)) 136 137(defun c-write (out form &optional no-package) 138 (cond 139 ((and (listp form) 140 (eq 'quote (car form))) 141 (c-format out "'") 142 (c-write out (cadr form) no-package)) 143 ((listp form) 144 (c-format out "(") 145 (loop for subform in form 146 for first-p = t then nil 147 unless first-p do (c-format out " ") 148 do (c-write out subform no-package)) 149 (c-format out ")")) 150 ((symbolp form) 151 (c-print-symbol out form no-package)))) 152 153;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms 154;;; later, if necessary. 155(defvar *auto-export* nil) 156 157(defun c-export (out symbol) 158 (when (and *auto-export* (not (keywordp symbol))) 159 (c-format out "(cl:export '") 160 (c-print-symbol out symbol t) 161 (c-format out ")~%"))) 162 163(defun c-section-header (out section-type section-symbol) 164 (format out "~% /* ~A section for ~S */~%" 165 section-type 166 section-symbol)) 167 168(defun remove-suffix (string suffix) 169 (let ((suffix-start (- (length string) (length suffix)))) 170 (if (and (> suffix-start 0) 171 (string= string suffix :start1 suffix-start)) 172 (subseq string 0 suffix-start) 173 string))) 174 175(defun strcat (&rest strings) 176 (apply #'concatenate 'string strings)) 177 178(defgeneric %process-grovel-form (name out arguments) 179 (:method (name out arguments) 180 (declare (ignore out arguments)) 181 (grovel-error "Unknown Grovel syntax: ~S" name))) 182 183(defun process-grovel-form (out form) 184 (%process-grovel-form (form-kind form) out (cdr form))) 185 186(defun form-kind (form) 187 ;; Using INTERN here instead of FIND-SYMBOL will result in less 188 ;; cryptic error messages when an undefined grovel/wrapper form is 189 ;; found. 190 (intern (symbol-name (car form)) '#:cffi-grovel)) 191 192(defvar *header-forms* '(c include define flag typedef)) 193 194(defun header-form-p (form) 195 (member (form-kind form) *header-forms*)) 196 197(defun make-c-file-name (output-defaults) 198 (make-pathname :type "c" :defaults output-defaults)) 199 200(defun generate-c-file (input-file output-defaults) 201 (let ((c-file (make-c-file-name output-defaults))) 202 (with-open-file (out c-file :direction :output :if-exists :supersede) 203 (with-open-file (in input-file :direction :input) 204 (flet ((read-forms (s) 205 (do ((forms ()) 206 (form (read s nil nil) (read s nil nil))) 207 ((null form) (nreverse forms)) 208 (labels 209 ((process-form (f) 210 (case (form-kind f) 211 (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead."))) 212 (case (form-kind f) 213 (in-package 214 (setf *package* (find-package (second f))) 215 (push f forms)) 216 (progn 217 ;; flatten progn forms 218 (mapc #'process-form (rest f))) 219 (t (push f forms))))) 220 (process-form form))))) 221 (let* ((forms (read-forms in)) 222 (header-forms (remove-if-not #'header-form-p forms)) 223 (body-forms (remove-if #'header-form-p forms))) 224 (write-string *header* out) 225 (dolist (form header-forms) 226 (process-grovel-form out form)) 227 (write-string *prologue* out) 228 (dolist (form body-forms) 229 (process-grovel-form out form)) 230 (write-string *postscript* out))))) 231 c-file)) 232 233(defparameter *exe-extension* #-windows nil #+windows "exe") 234 235(defun exe-filename (defaults) 236 (let ((path (make-pathname :type *exe-extension* 237 :defaults defaults))) 238 ;; It's necessary to prepend "./" to relative paths because some 239 ;; implementations of INVOKE use a shell. 240 (when (or (not (pathname-directory path)) 241 (eq :relative (car (pathname-directory path)))) 242 (setf path (make-pathname 243 :directory (list* :relative "." 244 (cdr (pathname-directory path))) 245 :defaults path))) 246 path)) 247 248(defun tmp-lisp-filename (defaults) 249 (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp") 250 :type "lisp" :defaults defaults)) 251 252(cffi:defcfun "getenv" :string 253 (name :string)) 254 255 256(defparameter *cc* 257 #+(or cygwin (not windows)) "cc" 258 #+(and windows (not cygwin)) "gcc") 259 260(defparameter *cc-flags* 261 (append 262 ;; For MacPorts 263 #+darwin (list "-I" "/opt/local/include/") 264 #-darwin nil 265 ;; ECL internal flags 266 #+ecl (list c::*cc-flags*) 267 ;; FreeBSD non-base header files 268 #+freebsd (list "-I" "/usr/local/include/"))) 269 270;;; FIXME: is there a better way to detect whether these flags 271;;; are necessary? 272(defparameter *cpu-word-size-flags* 273 #+arm 274 (list "-marm") 275 #-arm 276 (ecase (cffi:foreign-type-size :pointer) 277 (4 (list "-m32")) 278 (8 (list "-m64")))) 279 280(defparameter *platform-library-flags* 281 (list #+darwin "-bundle" 282 #-darwin "-shared" 283 #-windows "-fPIC")) 284 285(defun host-and-directory-namestring (pathname) 286 (namestring 287 (make-pathname :name nil 288 :type nil 289 :defaults pathname))) 290 291(defun cc-compile-and-link (input-file output-file &key library) 292 (let ((arglist 293 `(,(or (getenv "CC") *cc*) 294 ,@*cpu-word-size-flags* 295 ,@*cc-flags* 296 ;; add the cffi directory to the include path to make common.h visible 297 ,(format nil "-I~A" 298 (host-and-directory-namestring 299 (truename (asdf:system-definition-pathname :cffi-grovel)))) 300 ,@(when library *platform-library-flags*) 301 "-o" ,(native-namestring output-file) 302 ,(native-namestring input-file)))) 303 (when library 304 ;; if it's a library that may be used, remove it 305 ;; so we won't possibly be overwriting the code of any existing process 306 (ignore-some-conditions (file-error) 307 (delete-file output-file))) 308 (apply #'invoke arglist))) 309 310;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during 311;;; *the extent of a given grovel file. 312(defun process-grovel-file (input-file &optional (output-defaults input-file)) 313 (with-standard-io-syntax 314 (let* ((c-file (generate-c-file input-file output-defaults)) 315 (exe-file (exe-filename c-file)) 316 (lisp-file (tmp-lisp-filename c-file))) 317 (cc-compile-and-link c-file exe-file) 318 (invoke exe-file (native-namestring lisp-file)) 319 lisp-file))) 320 321;;; OUT is lexically bound to the output stream within BODY. 322(defmacro define-grovel-syntax (name lambda-list &body body) 323 (with-unique-names (name-var args) 324 `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args) 325 (declare (ignorable out)) 326 (destructuring-bind ,lambda-list ,args 327 ,@body)))) 328 329(define-grovel-syntax c (body) 330 (format out "~%~A~%" body)) 331 332(define-grovel-syntax include (&rest includes) 333 (format out "~{#include <~A>~%~}" includes)) 334 335(define-grovel-syntax define (name &optional value) 336 (format out "#define ~A~@[ ~A~]~%" name value)) 337 338(define-grovel-syntax typedef (base-type new-type) 339 (format out "typedef ~A ~A;~%" base-type new-type)) 340 341;;; Is this really needed? 342(define-grovel-syntax ffi-typedef (new-type base-type) 343 (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type)) 344 345(define-grovel-syntax flag (&rest flags) 346 (appendf *cc-flags* (trim-whitespace flags))) 347 348(define-grovel-syntax cc-flags (&rest flags) 349 (appendf *cc-flags* (trim-whitespace flags))) 350 351(define-grovel-syntax pkg-config-cflags (pkg &key optional) 352 (block nil 353 (handler-bind 354 ((error (lambda (e) 355 (when optional 356 (format *debug-io* "~&ERROR: ~a" e) 357 (format *debug-io* "~&Attempting to continue anyway.~%") 358 (return))))) 359 (appendf *cc-flags* 360 (trim-whitespace (list (invoke "pkg-config" pkg "--cflags"))))))) 361 362;;; This form also has some "read time" effects. See GENERATE-C-FILE. 363(define-grovel-syntax in-package (name) 364 (c-format out "(cl:in-package #:~A)~%~%" name)) 365 366(define-grovel-syntax ctype (lisp-name size-designator) 367 (c-section-header out "ctype" lisp-name) 368 (c-export out lisp-name) 369 (c-format out "(cffi:defctype ") 370 (c-print-symbol out lisp-name t) 371 (c-format out " ") 372 (format out "~& type_name(output, TYPE_SIGNED_P(~A), ~:[sizeof(~A)~;~D~]);~%" 373 size-designator 374 (etypecase size-designator 375 (string nil) 376 (integer t)) 377 size-designator) 378 (c-format out ")~%") 379 (unless (keywordp lisp-name) 380 (c-export out lisp-name)) 381 (let ((size-of-constant-name (symbolicate '#:size-of- lisp-name))) 382 (c-export out size-of-constant-name) 383 (c-format out "(cl:defconstant " 384 size-of-constant-name lisp-name) 385 (c-print-symbol out size-of-constant-name) 386 (c-format out " (cffi:foreign-type-size '") 387 (c-print-symbol out lisp-name) 388 (c-format out "))~%"))) 389 390;;; Syntax differs from anything else in CFFI. Fix? 391(define-grovel-syntax constant ((lisp-name &rest c-names) 392 &key (type 'integer) documentation optional) 393 (when (keywordp lisp-name) 394 (setf lisp-name (format-symbol "~A" lisp-name))) 395 (c-section-header out "constant" lisp-name) 396 (dolist (c-name c-names) 397 (format out "~&#ifdef ~A~%" c-name) 398 (c-export out lisp-name) 399 (c-format out "(cl:defconstant ") 400 (c-print-symbol out lisp-name t) 401 (c-format out " ") 402 (ecase type 403 (integer 404 (format out "~& if(_64_BIT_VALUE_FITS_SIGNED_P(~A))~%" c-name) 405 (format out " fprintf(output, \"%lli\", (int64_t) ~A);" c-name) 406 (format out "~& else~%") 407 (format out " fprintf(output, \"%llu\", (uint64_t) ~A);" c-name)) 408 (double-float 409 (format out "~& fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name))) 410 (when documentation 411 (c-format out " ~S" documentation)) 412 (c-format out ")~%") 413 (format out "~&#else~%")) 414 (unless optional 415 (c-format out "(cl:warn 'cffi-grovel:missing-definition :name '~A)~%" 416 lisp-name)) 417 (dotimes (i (length c-names)) 418 (format out "~&#endif~%"))) 419 420(define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots) 421 (let ((documentation (when (stringp (car slots)) (pop slots)))) 422 (c-section-header out "cunion" union-lisp-name) 423 (c-export out union-lisp-name) 424 (dolist (slot slots) 425 (let ((slot-lisp-name (car slot))) 426 (c-export out slot-lisp-name))) 427 (c-format out "(cffi:defcunion (") 428 (c-print-symbol out union-lisp-name t) 429 (c-printf out " :size %i)" (format nil "sizeof(~A)" union-c-name)) 430 (when documentation 431 (c-format out "~% ~S" documentation)) 432 (dolist (slot slots) 433 (destructuring-bind (slot-lisp-name slot-c-name &key type count) 434 slot 435 (declare (ignore slot-c-name)) 436 (c-format out "~% (") 437 (c-print-symbol out slot-lisp-name t) 438 (c-format out " ") 439 (c-write out type) 440 (etypecase count 441 (integer 442 (c-format out " :count ~D" count)) 443 ((eql :auto) 444 ;; nb, works like :count :auto does in cstruct below 445 (c-printf out " :count %i" 446 (format nil "sizeof(~A)" union-c-name))) 447 (null t)) 448 (c-format out ")"))) 449 (c-format out ")~%"))) 450 451(defun make-from-pointer-function-name (type-name) 452 (symbolicate '#:make- type-name '#:-from-pointer)) 453 454;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much 455;;; cleaner way to do this. Unless I can find any advantage in doing 456;;; it this way I'll delete this soon. --luis 457(define-grovel-syntax cstruct-and-class-item (&rest arguments) 458 (process-grovel-form out (cons 'cstruct arguments)) 459 (destructuring-bind (struct-lisp-name struct-c-name &rest slots) 460 arguments 461 (declare (ignore struct-c-name)) 462 (let* ((slot-names (mapcar #'car slots)) 463 (reader-names (mapcar 464 (lambda (slot-name) 465 (intern 466 (strcat (symbol-name struct-lisp-name) "-" 467 (symbol-name slot-name)))) 468 slot-names)) 469 (initarg-names (mapcar 470 (lambda (slot-name) 471 (intern (symbol-name slot-name) "KEYWORD")) 472 slot-names)) 473 (slot-decoders (mapcar (lambda (slot) 474 (destructuring-bind 475 (lisp-name c-name 476 &key type count 477 &allow-other-keys) 478 slot 479 (declare (ignore lisp-name c-name)) 480 (cond ((and (eq type :char) count) 481 'cffi:foreign-string-to-lisp) 482 (t nil)))) 483 slots)) 484 (defclass-form 485 `(defclass ,struct-lisp-name () 486 ,(mapcar (lambda (slot-name initarg-name reader-name) 487 `(,slot-name :initarg ,initarg-name 488 :reader ,reader-name)) 489 slot-names 490 initarg-names 491 reader-names))) 492 (make-function-name 493 (make-from-pointer-function-name struct-lisp-name)) 494 (make-defun-form 495 ;; this function is then used as a constructor for this class. 496 `(defun ,make-function-name (pointer) 497 (cffi:with-foreign-slots 498 (,slot-names pointer ,struct-lisp-name) 499 (make-instance ',struct-lisp-name 500 ,@(loop for slot-name in slot-names 501 for initarg-name in initarg-names 502 for slot-decoder in slot-decoders 503 collect initarg-name 504 if slot-decoder 505 collect `(,slot-decoder ,slot-name) 506 else collect slot-name)))))) 507 (c-export out make-function-name) 508 (dolist (reader-name reader-names) 509 (c-export out reader-name)) 510 (c-write out defclass-form) 511 (c-write out make-defun-form)))) 512 513(define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slots) 514 (let ((documentation (when (stringp (car slots)) (pop slots)))) 515 (c-section-header out "cstruct" struct-lisp-name) 516 (c-export out struct-lisp-name) 517 (dolist (slot slots) 518 (let ((slot-lisp-name (car slot))) 519 (c-export out slot-lisp-name))) 520 (c-format out "(cffi:defcstruct (") 521 (c-print-symbol out struct-lisp-name t) 522 (c-printf out " :size %i)" 523 (format nil "sizeof(~A)" struct-c-name)) 524 (when documentation 525 (c-format out "~% ~S" documentation)) 526 (dolist (slot slots) 527 (destructuring-bind (slot-lisp-name slot-c-name &key type count) 528 slot 529 (c-format out "~% (") 530 (c-print-symbol out slot-lisp-name t) 531 (c-format out " ") 532 (etypecase type 533 ((eql :auto) 534 (format out "~& SLOT_SIGNED_P(autotype_tmp, ~A, ~A~@[[0]~]);~@*~%~ 535 ~& type_name(output, autotype_tmp, sizeofslot(~A, ~A~@[[0]~]));~%" 536 struct-c-name 537 slot-c-name 538 (not (null count)))) 539 ((or cons symbol) 540 (c-write out type)) 541 (string 542 (c-format out "~A" type))) 543 (etypecase count 544 (null t) 545 (integer 546 (c-format out " :count ~D" count)) 547 ((eql :auto) 548 (c-printf out " :count %i" 549 (format nil "countofslot(~A, ~A)" 550 struct-c-name 551 slot-c-name))) 552 ((or symbol string) 553 (format out "~&#ifdef ~A~%" count) 554 (c-printf out " :count %i" 555 (format nil "~A" count)) 556 (format out "~&#endif~%"))) 557 (c-printf out " :offset %li)" 558 (format nil "offsetof(~A, ~A)" 559 struct-c-name 560 slot-c-name)))) 561 (c-format out ")~%") 562 (let ((size-of-constant-name 563 (symbolicate '#:size-of- struct-lisp-name))) 564 (c-export out size-of-constant-name) 565 (c-format out "(cl:defconstant " 566 size-of-constant-name struct-lisp-name) 567 (c-print-symbol out size-of-constant-name) 568 (c-format out " (cffi:foreign-type-size '(:struct ") 569 (c-print-symbol out struct-lisp-name) 570 (c-format out ")))~%")))) 571 572(defmacro define-pseudo-cvar (str name type &key read-only) 573 (let ((c-parse (let ((*read-eval* nil) 574 (*readtable* (copy-readtable nil))) 575 (setf (readtable-case *readtable*) :preserve) 576 (read-from-string str)))) 577 (typecase c-parse 578 (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name 579 :read-only ,read-only) 580 ,type)) 581 (list (unless (and (= (length c-parse) 2) 582 (null (second c-parse)) 583 (symbolp (first c-parse)) 584 (eql #\* (char (symbol-name (first c-parse)) 0))) 585 (grovel-error "Unable to parse c-string ~s." str)) 586 (let ((func-name (symbolicate "%" name '#:-accessor))) 587 `(progn 588 (declaim (inline ,func-name)) 589 (cffi:defcfun (,(string-trim "*" (symbol-name (first c-parse))) 590 ,func-name) :pointer) 591 (define-symbol-macro ,name 592 (cffi:mem-ref (,func-name) ',type))))) 593 (t (grovel-error "Unable to parse c-string ~s." str))))) 594 595(defun foreign-name-to-symbol (s) 596 (intern (substitute #\- #\_ (string-upcase s)))) 597 598(defun choose-lisp-and-foreign-names (string-or-list) 599 (etypecase string-or-list 600 (string (values string-or-list (foreign-name-to-symbol string-or-list))) 601 (list (destructuring-bind (fname lname &rest args) string-or-list 602 (declare (ignore args)) 603 (assert (and (stringp fname) (symbolp lname))) 604 (values fname lname))))) 605 606(define-grovel-syntax cvar (name type &key read-only) 607 (multiple-value-bind (c-name lisp-name) 608 (choose-lisp-and-foreign-names name) 609 (c-section-header out "cvar" lisp-name) 610 (c-export out lisp-name) 611 (c-printf out "(cffi-grovel::define-pseudo-cvar \"%s\" " 612 (format nil "indirect_stringify(~A)" c-name)) 613 (c-print-symbol out lisp-name t) 614 (c-format out " ") 615 (c-write out type) 616 (when read-only 617 (c-format out " :read-only t")) 618 (c-format out ")~%"))) 619 620;;; FIXME: where would docs on enum elements go? 621(define-grovel-syntax cenum (name &rest enum-list) 622 (destructuring-bind (name &key base-type define-constants) 623 (ensure-list name) 624 (c-section-header out "cenum" name) 625 (c-export out name) 626 (c-format out "(cffi:defcenum (") 627 (c-print-symbol out name t) 628 (when base-type 629 (c-printf out " ") 630 (c-print-symbol out base-type t)) 631 (c-format out ")") 632 (dolist (enum enum-list) 633 (destructuring-bind ((lisp-name &rest c-names) &key documentation) 634 enum 635 (declare (ignore documentation)) 636 (check-type lisp-name keyword) 637 (loop for c-name in c-names do 638 (check-type c-name string) 639 (c-format out " (") 640 (c-print-symbol out lisp-name) 641 (c-format out " ") 642 (c-print-integer-constant out c-name base-type) 643 (c-format out ")~%")))) 644 (c-format out ")~%") 645 (when define-constants 646 (define-constants-from-enum out enum-list)))) 647 648(define-grovel-syntax constantenum (name &rest enum-list) 649 (destructuring-bind (name &key base-type define-constants) 650 (ensure-list name) 651 (c-section-header out "constantenum" name) 652 (c-export out name) 653 (c-format out "(cffi:defcenum (") 654 (c-print-symbol out name t) 655 (when base-type 656 (c-printf out " ") 657 (c-print-symbol out base-type t)) 658 (c-format out ")") 659 (dolist (enum enum-list) 660 (destructuring-bind ((lisp-name &rest c-names) 661 &key optional documentation) enum 662 (declare (ignore documentation)) 663 (check-type lisp-name keyword) 664 (c-format out "~% (") 665 (c-print-symbol out lisp-name) 666 (loop for c-name in c-names do 667 (check-type c-name string) 668 (format out "~&#ifdef ~A~%" c-name) 669 (c-format out " ") 670 (c-print-integer-constant out c-name base-type) 671 (format out "~&#else~%")) 672 (unless optional 673 (c-format out 674 "~% #.(cl:progn ~ 675 (cl:warn 'cffi-grovel:missing-definition :name '~A) ~ 676 -1)" 677 lisp-name)) 678 (dotimes (i (length c-names)) 679 (format out "~&#endif~%")) 680 (c-format out ")"))) 681 (c-format out ")~%") 682 (when define-constants 683 (define-constants-from-enum out enum-list)))) 684 685(defun define-constants-from-enum (out enum-list) 686 (dolist (enum enum-list) 687 (destructuring-bind ((lisp-name &rest c-names) &rest options) 688 enum 689 (%process-grovel-form 690 'constant out 691 `((,(intern (string lisp-name)) ,(car c-names)) 692 ,@options))))) 693 694(defun convert-intmax-constant (constant base-type) 695 "Convert the C CONSTANT to an integer of BASE-TYPE. The constant is 696assumed to be an integer printed using the PRIiMAX printf(3) format 697string." 698 ;; | C Constant | Type | Return Value | Notes | 699 ;; |------------+---------+--------------+---------------------------------------| 700 ;; | -1 | :int32 | -1 | | 701 ;; | 0xffffffff | :int32 | -1 | CONSTANT may be a positive integer if | 702 ;; | | | | sizeof(intmax_t) > sizeof(int32_t) | 703 ;; | 0xffffffff | :uint32 | 4294967295 | | 704 ;; | -1 | :uint32 | 4294967295 | | 705 ;; |------------+---------+--------------+---------------------------------------| 706 (let* ((canonical-type (cffi::canonicalize-foreign-type base-type)) 707 (type-bits (* 8 (cffi:foreign-type-size canonical-type))) 708 (2^n (ash 1 type-bits))) 709 (ecase canonical-type 710 ((:unsigned-char :unsigned-short :unsigned-int 711 :unsigned-long :unsigned-long-long) 712 (mod constant 2^n)) 713 ((:char :short :int :long :long-long) 714 (let ((v (mod constant 2^n))) 715 (if (logbitp (1- type-bits) v) 716 (- (mask-field (byte (1- type-bits) 0) v) 717 (ash 1 (1- type-bits))) 718 v)))))) 719 720(defun foreign-type-to-printf-specification (type) 721 "Return the printf specification associated with the foreign type TYPE." 722 (ecase type 723 (:char 724 "\"%hhd\"") 725 ((:unsigned-char :uchar) 726 "\"%hhu\"") 727 (:short 728 "\"%hd\"") 729 ((:unsigned-short :ushort) 730 "\"%hu\"") 731 (:int 732 "\"%d\"") 733 ((:unsigned-int :uint) 734 "\"%u\"") 735 (:long 736 "\"%ld\"") 737 ((:unsigned-long :ulong) 738 "\"%lu\"") 739 ((:long-long :llong) 740 "\"%lld\"") 741 ((:unsigned-long-long :ullong) 742 "\"%llu\"") 743 (:int8 744 "\"%\"PRId8") 745 (:uint8 746 "\"%\"PRIu8") 747 (:int16 748 "\"%\"PRId16") 749 (:uint16 750 "\"%\"PRIu16") 751 (:int32 752 "\"%\"PRId32") 753 (:uint32 754 "\"%\"PRIu32") 755 (:int64 756 "\"%\"PRId64") 757 (:uint64 758 "\"%\"PRIu64"))) 759 760;; Defines a bitfield, with elements specified as ((LISP-NAME C-NAME) 761;; &key DOCUMENTATION). NAME-AND-OPTS can be either a symbol as name, 762;; or a list (NAME &key BASE-TYPE). 763(define-grovel-syntax bitfield (name-and-opts &rest masks) 764 (destructuring-bind (name &key base-type) 765 (ensure-list name-and-opts) 766 (c-section-header out "bitfield" name) 767 (c-export out name) 768 (c-format out "(cffi:defbitfield (") 769 (c-print-symbol out name t) 770 (when base-type 771 (c-printf out " ") 772 (c-print-symbol out base-type t)) 773 (c-format out ")") 774 (dolist (mask masks) 775 (destructuring-bind ((lisp-name &rest c-names) 776 &key optional documentation) mask 777 (declare (ignore documentation)) 778 (check-type lisp-name symbol) 779 (c-format out "~% (") 780 (c-print-symbol out lisp-name) 781 (c-format out " ") 782 (dolist (c-name c-names) 783 (check-type c-name string) 784 (format out "~&#ifdef ~A~%" c-name) 785 (format out "~& fprintf(output, ~A, ~A);~%" 786 (foreign-type-to-printf-specification (or base-type :int)) 787 c-name) 788 (format out "~&#else~%")) 789 (unless optional 790 (c-format out 791 "~% #.(cl:progn ~ 792 (cl:warn 'cffi-grovel:missing-definition :name '~A) ~ 793 -1)" 794 lisp-name)) 795 (dotimes (i (length c-names)) 796 (format out "~&#endif~%")) 797 (c-format out ")"))) 798 (c-format out ")~%"))) 799 800 801;;;# Wrapper Generation 802;;; 803;;; Here we generate a C file from a s-exp specification but instead 804;;; of compiling and running it, we compile it as a shared library 805;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY. 806;;; 807;;; Useful to get at macro functionality, errno, system calls, 808;;; functions that handle structures by value, etc... 809;;; 810;;; Matching CFFI bindings are generated along with said C file. 811 812(defun process-wrapper-form (out form) 813 (%process-wrapper-form (form-kind form) out (cdr form))) 814 815;;; The various operators push Lisp forms onto this list which will be 816;;; written out by PROCESS-WRAPPER-FILE once everything is processed. 817(defvar *lisp-forms*) 818 819(defun generate-c-lib-file (input-file output-defaults) 820 (let ((*lisp-forms* nil) 821 (c-file (make-c-file-name output-defaults))) 822 (with-open-file (out c-file :direction :output :if-exists :supersede) 823 (with-open-file (in input-file :direction :input) 824 (write-string *header* out) 825 (loop for form = (read in nil nil) while form 826 do (process-wrapper-form out form)))) 827 (values c-file (nreverse *lisp-forms*)))) 828 829(defun lib-filename (defaults) 830 (make-pathname :type (subseq (cffi::default-library-suffix) 1) 831 :defaults defaults)) 832 833(defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults) 834 (let ((lisp-file (tmp-lisp-filename output-defaults))) 835 (with-open-file (out lisp-file :direction :output :if-exists :supersede) 836 (format out ";;;; This file was automatically generated by cffi-grovel.~%~ 837 ;;;; Do not edit by hand.~%") 838 (let ((*package* (find-package '#:cl)) 839 (named-library-name 840 (let ((*package* (find-package :keyword)) 841 (*read-eval* nil)) 842 (read-from-string lib-soname)))) 843 (pprint `(progn 844 (cffi:define-foreign-library 845 (,named-library-name 846 :type :grovel-wrapper 847 :search-path ,(directory-namestring lib-file)) 848 (t ,(namestring (lib-filename lib-soname)))) 849 (cffi:use-foreign-library ,named-library-name)) 850 out) 851 (fresh-line out)) 852 (dolist (form lisp-forms) 853 (print form out)) 854 (terpri out)) 855 lisp-file)) 856 857(defun make-soname (lib-soname output-defaults) 858 (make-pathname :name lib-soname 859 :defaults output-defaults)) 860 861;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during 862;;; *the extent of a given wrapper file. 863(defun process-wrapper-file (input-file output-defaults lib-soname) 864 (with-standard-io-syntax 865 (let ((lib-file 866 (lib-filename (make-soname lib-soname output-defaults)))) 867 (multiple-value-bind (c-file lisp-forms) 868 (generate-c-lib-file input-file output-defaults) 869 (cc-compile-and-link c-file lib-file :library t) 870 ;; FIXME: hardcoded library path. 871 (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults) 872 lib-file))))) 873 874(defgeneric %process-wrapper-form (name out arguments) 875 (:method (name out arguments) 876 (declare (ignore out arguments)) 877 (grovel-error "Unknown Grovel syntax: ~S" name))) 878 879;;; OUT is lexically bound to the output stream within BODY. 880(defmacro define-wrapper-syntax (name lambda-list &body body) 881 (with-unique-names (name-var args) 882 `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,args) 883 (declare (ignorable out)) 884 (destructuring-bind ,lambda-list ,args 885 ,@body)))) 886 887(define-wrapper-syntax progn (&rest forms) 888 (dolist (form forms) 889 (process-wrapper-form out form))) 890 891(define-wrapper-syntax in-package (name) 892 (setq *package* (find-package name)) 893 (push `(in-package ,name) *lisp-forms*)) 894 895(define-wrapper-syntax c (&rest strings) 896 (dolist (string strings) 897 (write-line string out))) 898 899(define-wrapper-syntax flag (&rest flags) 900 (appendf *cc-flags* (trim-whitespace flags))) 901 902(define-wrapper-syntax proclaim (&rest proclamations) 903 (push `(proclaim ,@proclamations) *lisp-forms*)) 904 905(define-wrapper-syntax declaim (&rest declamations) 906 (push `(declaim ,@declamations) *lisp-forms*)) 907 908(define-wrapper-syntax define (name &optional value) 909 (format out "#define ~A~@[ ~A~]~%" name value)) 910 911(define-wrapper-syntax include (&rest includes) 912 (format out "~{#include <~A>~%~}" includes)) 913 914;;; FIXME: this function is not complete. Should probably follow 915;;; typedefs? Should definitely understand pointer types. 916(defun c-type-name (typespec) 917 (let ((spec (ensure-list typespec))) 918 (if (stringp (car spec)) 919 (car spec) 920 (case (car spec) 921 ((:uchar :unsigned-char) "unsigned char") 922 ((:unsigned-short :ushort) "unsigned short") 923 ((:unsigned-int :uint) "unsigned int") 924 ((:unsigned-long :ulong) "unsigned long") 925 ((:long-long :llong) "long long") 926 ((:unsigned-long-long :ullong) "unsigned long long") 927 (:pointer "void*") 928 (:string "char*") 929 (t (cffi::foreign-name (car spec) nil)))))) 930 931(defun cffi-type (typespec) 932 (if (and (listp typespec) (stringp (car typespec))) 933 (second typespec) 934 typespec)) 935 936(defun symbol* (s) 937 (check-type s (and symbol (not null))) 938 s) 939 940(define-wrapper-syntax defwrapper (name-and-options rettype &rest args) 941 (multiple-value-bind (lisp-name foreign-name options) 942 (cffi::parse-name-and-options name-and-options) 943 (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap")) 944 (fargs (mapcar (lambda (arg) 945 (list (c-type-name (second arg)) 946 (cffi::foreign-name (first arg) nil))) 947 args)) 948 (fargnames (mapcar #'second fargs))) 949 ;; output C code 950 (format out "~A ~A" (c-type-name rettype) foreign-name-wrap) 951 (format out "(~{~{~A ~A~}~^, ~})~%" fargs) 952 (format out "{~% return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames) 953 ;; matching bindings 954 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options) 955 ,(cffi-type rettype) 956 ,@(mapcar (lambda (arg) 957 (list (symbol* (first arg)) 958 (cffi-type (second arg)))) 959 args)) 960 *lisp-forms*)))) 961 962(define-wrapper-syntax defwrapper* (name-and-options rettype args &rest c-lines) 963 ;; output C code 964 (multiple-value-bind (lisp-name foreign-name options) 965 (cffi::parse-name-and-options name-and-options) 966 (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap")) 967 (fargs (mapcar (lambda (arg) 968 (list (c-type-name (second arg)) 969 (cffi::foreign-name (first arg) nil))) 970 args))) 971 (format out "~A ~A" (c-type-name rettype) 972 foreign-name-wrap) 973 (format out "(~{~{~A ~A~}~^, ~})~%" fargs) 974 (format out "{~%~{ ~A~%~}}~%~%" c-lines) 975 ;; matching bindings 976 (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options) 977 ,(cffi-type rettype) 978 ,@(mapcar (lambda (arg) 979 (list (symbol* (first arg)) 980 (cffi-type (second arg)))) 981 args)) 982 *lisp-forms*)))) 983