grovel/grovel.lisp

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