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