src/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, 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 #:iolib-grovel)
  32
  33 ;;;# Utils
  34
  35 (defun trim-whitespace (strings)
  36   (loop for s in strings
  37         collect (string-trim '(#\Space #\Tab) s)))
  38
  39 (defun string* (s)
  40   "Coerce S to a string, making sure that it returns an extended string"
  41   (map 'string #'identity (string s)))
  42
  43 ;;;# Error Conditions
  44
  45 ;;; This warning is signalled when iolib-grovel can't find some macro.
  46 ;;; Signalled by CONSTANT or CONSTANTENUM.
  47 (define-condition missing-definition (warning)
  48   ((%name :initarg :name :reader name-of))
  49   (:report (lambda (condition stream)
  50              (format stream "No definition for ~A"
  51                      (name-of condition)))))
  52
  53 ;;;# Grovelling
  54
  55 ;;; The header of the intermediate C file.
  56 (defparameter *header*
  57   "/*
  58  * This file has been automatically generated by iolib-grovel.
  59  * Do not edit it by hand.
  60  */
  61
  62 ")
  63
  64 ;;; C code generated by iolib-grovel is inserted between the contents
  65 ;;; of *PROLOGUE* and *POSTSCRIPT*, inside the main function's body.
  66
  67 (defparameter *prologue*
  68   "
  69 #include <grovel-common.h>
  70
  71 int main(int argc, char**argv) {
  72   int autotype_tmp;
  73   FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;
  74   fprintf(output, \";;;; This file has been automatically generated by \"
  75                   \"iolib-grovel.\\n;;;; Do not edit it by hand.\\n\\n\");
  76
  77 ")
  78
  79 (defparameter *postscript*
  80   "
  81   if  (output != stdout)
  82     fclose(output);
  83   return 0;
  84 }
  85 ")
  86
  87 (defun unescape-for-c (text)
  88   (with-output-to-string (result)
  89     (loop for i below (length text)
  90           for char = (char text i) do
  91           (cond ((eql char #\") (princ "\\\"" result))
  92                 ((eql char #\newline) (princ "\\n" result))
  93                 (t (princ char result))))))
  94
  95 (defun c-format (out fmt &rest args)
  96   (let ((text (unescape-for-c (format nil "~?" fmt args))))
  97     (format out "~&  fputs(\"~A\", output);~%" text)))
  98
  99 (defun c-printf (out fmt &rest args)
 100   (flet ((item (item)
 101            (format out "~A" (unescape-for-c (format nil item)))))
 102     (format out "~&  fprintf(output, \"")
 103     (item fmt)
 104     (format out "\"")
 105     (loop for arg in args do
 106           (format out ", ")
 107           (item arg))
 108     (format out ");~%")))
 109
 110 ;;; TODO: handle packages in a better way. One way is to process each
 111 ;;; grovel form as it is read (like we already do for wrapper
 112 ;;; forms). This way in can expect *PACKAGE* to have sane values.
 113 ;;; This would require that "header forms" come before any other
 114 ;;; forms.
 115 (defun c-print-symbol (out symbol &optional no-package)
 116   (c-format out
 117             (let ((package (symbol-package symbol)))
 118               (cond
 119                 ((eq (find-package '#:keyword) package) ":~(~A~)")
 120                 (no-package "~(~A~)")
 121                 ((eq (find-package '#:cl) package) "cl:~(~A~)")
 122                 (t "~(~A~)")))
 123             symbol))
 124
 125 (defun c-write (out form &key recursive)
 126   (cond
 127     ((and (listp form)
 128           (eq 'quote (car form)))
 129      (c-format out "'")
 130      (c-write out (cadr form) :recursive t))
 131     ((listp form)
 132      (c-format out "(")
 133      (loop for subform in form
 134            for first-p = t then nil
 135            unless first-p do (c-format out " ")
 136            do (c-write out subform :recursive t))
 137      (c-format out ")"))
 138     ((symbolp form)
 139      (c-print-symbol out form)))
 140   (unless recursive
 141     (c-format out "~%")))
 142
 143 ;;; Always NIL for now, add {ENABLE,DISABLE}-AUTO-EXPORT grovel forms
 144 ;;; later, if necessary.
 145 (defvar *auto-export* nil)
 146
 147 (defun c-export (out symbol)
 148   (when (and *auto-export* (not (keywordp symbol)))
 149     (c-format out "(cl:export '")
 150     (c-print-symbol out symbol t)
 151     (c-format out ")~%")))
 152
 153 (defun c-section-header (out section-type section-symbol)
 154   (format out "~%  /* ~A section for ~S */~%"
 155           section-type
 156           section-symbol))
 157
 158 (defun remove-suffix (string suffix)
 159   (let ((suffix-start (- (length string) (length suffix))))
 160     (if (and (> suffix-start 0)
 161              (string= string suffix :start1 suffix-start))
 162         (subseq string 0 suffix-start)
 163         string)))
 164
 165 (defun strcat (&rest strings)
 166   (apply #'concatenate 'string strings))
 167
 168 (defgeneric %process-grovel-form (name out arguments)
 169   (:method (name out arguments)
 170     (declare (ignore out arguments))
 171     (error "Unknown Grovel syntax: ~S" name)))
 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)) '#:iolib-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   (let ((c-file (make-pathname :type "c" :defaults output-defaults)))
 189     (with-open-file (out c-file :direction :output :if-exists :supersede)
 190       (with-open-file (in input-file :direction :input)
 191         (flet ((read-forms (s)
 192                  (do ((forms ())
 193                       (form (read s nil nil) (read s nil nil)))
 194                      ((null form) (nreverse forms))
 195                    (labels
 196                        ((process-form (f)
 197                           (case (form-kind f)
 198                             (flag (warn "Groveler clause FLAG is deprecated, use CC-FLAGS instead.")))
 199                           (case (form-kind f)
 200                             (in-package
 201                              (setf *package* (find-package (second f)))
 202                              (push f forms))
 203                             (progn
 204                               ;; flatten progn forms
 205                               (mapc #'process-form (rest f)))
 206                             (t (push f forms)))))
 207                      (process-form form)))))
 208           (let* ((forms (read-forms in))
 209                  (header-forms (remove-if-not #'header-form-p forms))
 210                  (body-forms (remove-if #'header-form-p forms)))
 211             (write-string *header* out)
 212             (dolist (form header-forms)
 213               (process-grovel-form out form))
 214             (write-string *prologue* out)
 215             (dolist (form body-forms)
 216               (process-grovel-form out form))
 217             (write-string *postscript* out)))))
 218     c-file))
 219
 220 (defparameter *exe-extension* #-windows nil #+windows "exe")
 221
 222 (defun exe-filename (defaults)
 223   (let ((path (make-pathname :type *exe-extension*
 224                              :defaults defaults)))
 225     ;; It's necessary to prepend "./" to relative paths because some
 226     ;; implementations of INVOKE use a shell.
 227     (when (or (not (pathname-directory path))
 228               (eq :relative (car (pathname-directory path))))
 229       (setf path (make-pathname
 230                   :directory (list* :relative "."
 231                                     (cdr (pathname-directory path)))
 232                   :defaults path)))
 233     path))
 234
 235 (defun tmp-lisp-filename (defaults)
 236   (make-pathname :name (strcat (pathname-name defaults) ".grovel-tmp")
 237                  :type "lisp" :defaults defaults))
 238
 239 (cffi:defcfun "getenv" :string
 240   (name :string))
 241 \f
 242
 243 (defparameter *cxx*
 244   #+(or cygwin (not windows)) "g++"
 245   #+(and windows (not cygwin)) "c:/msys/1.0/bin/g++.exe")
 246
 247 (defparameter *cc-flags*
 248   (append
 249    (list "-Wno-write-strings")
 250    ;; For MacPorts
 251    #+darwin (list "-I" "/opt/local/include/")
 252    #-darwin nil
 253    ;; ECL internal flags
 254    #+ecl (list c::*cc-flags*)
 255    ;; FreeBSD non-base header files
 256    #+freebsd (list "-I" "/usr/local/include/")))
 257
 258 ;;; FIXME: is there a better way to detect whether these flags
 259 ;;; are necessary?
 260 (defparameter *cpu-word-size-flags*
 261   #-(or arm x86 x86-64 sparc sparc64)
 262   '()
 263   #+arm
 264   (list "-marm")
 265   #+(or x86 x86-64 sparc sparc64)
 266   (ecase (cffi:foreign-type-size :pointer)
 267     (4 (list "-m32"))
 268     (8 (list "-m64"))))
 269
 270 (defparameter *platform-library-flags*
 271   (list #+darwin "-bundle"
 272         #-darwin "-shared"
 273         #-windows "-fPIC"))
 274
 275 (defun cc-compile-and-link (input-file output-file &key library)
 276   (let ((arglist
 277          `(,(or (getenv "CXX") *cxx*)
 278            ,@*cpu-word-size-flags*
 279            ,@*cc-flags*
 280            ;; add the cffi directory to the include path to make common.h visible
 281            ,(format nil "-I~A"
 282                     (directory-namestring
 283                      (asdf:component-pathname
 284                       (asdf:find-system :iolib/grovel))))
 285            ,@(when library *platform-library-flags*)
 286            "-o" ,(native-namestring output-file)
 287            ,(native-namestring input-file))))
 288     (when library
 289       ;; if it's a library that may be used, remove it
 290       ;; so we won't possibly be overwriting the code of any existing process
 291       (ignore-some-conditions (file-error)
 292         (delete-file output-file)))
 293     (apply #'invoke arglist)))
 294
 295 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
 296 ;;; *the extent of a given grovel file.
 297 (defun process-grovel-file (input-file &optional (output-defaults input-file))
 298   (with-standard-io-syntax
 299     (let* ((c-file (generate-c-file input-file output-defaults))
 300            (exe-file (exe-filename c-file))
 301            (lisp-file (tmp-lisp-filename c-file)))
 302       (cc-compile-and-link c-file exe-file)
 303       (invoke exe-file (native-namestring lisp-file))
 304       lisp-file)))
 305
 306 ;;; OUT is lexically bound to the output stream within BODY.
 307 (defmacro define-grovel-syntax (name lambda-list &body body)
 308   (with-unique-names (name-var args)
 309     `(defmethod %process-grovel-form ((,name-var (eql ',name)) out ,args)
 310        (declare (ignorable out))
 311        (destructuring-bind ,lambda-list ,args
 312          ,@body))))
 313
 314 (define-grovel-syntax c (body)
 315   (format out "~%~A~%" body))
 316
 317 (define-grovel-syntax include (&rest includes)
 318   (format out "~{#include <~A>~%~}" includes))
 319
 320 (define-grovel-syntax define (name &optional value)
 321   (format out "#define ~A~@[ ~A~]~%" name value))
 322
 323 (define-grovel-syntax typedef (base-type new-type)
 324   (format out "typedef ~A ~A;~%" base-type new-type))
 325
 326 ;;; Is this really needed?
 327 (define-grovel-syntax ffi-typedef (new-type base-type)
 328   (c-format out "(cffi:defctype ~S ~S)~%" new-type base-type))
 329
 330 (define-grovel-syntax flag (&rest flags)
 331   (appendf *cc-flags* (trim-whitespace flags)))
 332
 333 (define-grovel-syntax cc-flags (&rest flags)
 334   (appendf *cc-flags* (trim-whitespace flags)))
 335
 336 ;;; This form also has some "read time" effects. See GENERATE-C-FILE.
 337 (define-grovel-syntax in-package (name)
 338   (c-format out "(cl:in-package ~S)~%~%" (string* name)))
 339
 340 (define-grovel-syntax ctype (lisp-name c-name)
 341   (c-section-header out "ctype" lisp-name)
 342   (format out "  CFFI_DEFCTYPE(~S, ~A);~%"
 343           (string* lisp-name) c-name))
 344
 345 (defun docstring-to-c (docstring)
 346   (if docstring (format nil "~S" docstring) "NULL"))
 347
 348 (define-grovel-syntax constant ((lisp-name &rest c-names) &key documentation optional)
 349   (c-section-header out "constant" lisp-name)
 350   (loop :for i :from 0
 351         :for c-name :in c-names :do
 352         (format out "~A defined(~A)~%" (if (zerop i) "#if" "#elif") c-name)
 353         (format out "  CFFI_DEFCONSTANT(~S, ~A, ~A);~%"
 354                 (string* lisp-name) c-name
 355                 (docstring-to-c documentation)))
 356   (unless optional
 357     (format out "#else~%  cffi_signal_missing_definition(output, ~S);~%"
 358             (string* lisp-name)))
 359   (format out "#endif~%"))
 360
 361 (define-grovel-syntax cunion (union-lisp-name union-c-name &rest slots)
 362   (let ((documentation (when (stringp (car slots)) (pop slots))))
 363     (c-section-header out "cunion" union-lisp-name)
 364     (format out "  CFFI_DEFCUNION_START(~S, ~A, ~A);~%"
 365             (string* union-lisp-name) union-c-name
 366             (docstring-to-c documentation))
 367     (dolist (slot slots)
 368       (destructuring-bind (slot-lisp-name slot-c-name &key type (count 1))
 369           slot
 370         (etypecase count
 371           ((eql :auto)
 372            (format out "  CFFI_DEFCUNION_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
 373                    union-c-name slot-c-name
 374                    (prin1-to-string slot-lisp-name) (prin1-to-string type)))
 375           ((or integer symbol string)
 376            (format out "  CFFI_DEFCUNION_SLOT(~A, ~A, ~S, ~S, ~A);~%"
 377                    union-c-name slot-c-name
 378                    (prin1-to-string slot-lisp-name) (prin1-to-string type) count)))))
 379     (format out "  CFFI_DEFCUNION_END;~%")
 380     (format out "  CFFI_DEFTYPEDEF(~S, ~S);~%"
 381             (string* union-lisp-name) (string* :union))
 382     (format out "  CFFI_DEFTYPESIZE(~S, ~A);~%"
 383             (string* union-lisp-name) union-c-name)))
 384
 385 (defun make-from-pointer-function-name (type-name)
 386   (symbolicate '#:make- type-name '#:-from-pointer))
 387
 388 ;;; DEFINE-C-STRUCT-WRAPPER (in ../src/types.lisp) seems like a much
 389 ;;; cleaner way to do this.  Unless I can find any advantage in doing
 390 ;;; it this way I'll delete this soon.  --luis
 391 (define-grovel-syntax cstruct-and-class-item (&rest arguments)
 392   (process-grovel-form out (cons 'cstruct arguments))
 393   (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
 394       arguments
 395     (declare (ignore struct-c-name))
 396     (let* ((slot-names (mapcar #'car slots))
 397            (reader-names (mapcar
 398                           (lambda (slot-name)
 399                             (intern
 400                              (strcat (symbol-name struct-lisp-name) "-"
 401                                      (symbol-name slot-name))))
 402                           slot-names))
 403            (initarg-names (mapcar
 404                            (lambda (slot-name)
 405                              (intern (symbol-name slot-name) "KEYWORD"))
 406                            slot-names))
 407            (slot-decoders (mapcar (lambda (slot)
 408                                     (destructuring-bind
 409                                           (lisp-name c-name
 410                                                      &key type count
 411                                                      &allow-other-keys)
 412                                         slot
 413                                       (declare (ignore lisp-name c-name))
 414                                       (cond ((and (eq type :char) count)
 415                                              'cffi:foreign-string-to-lisp)
 416                                             (t nil))))
 417                                   slots))
 418            (defclass-form
 419             `(defclass ,struct-lisp-name ()
 420                ,(mapcar (lambda (slot-name initarg-name reader-name)
 421                           `(,slot-name :initarg ,initarg-name
 422                                        :reader ,reader-name))
 423                         slot-names
 424                         initarg-names
 425                         reader-names)))
 426            (make-function-name
 427             (make-from-pointer-function-name struct-lisp-name))
 428            (make-defun-form
 429             ;; this function is then used as a constructor for this class.
 430             `(defun ,make-function-name (pointer)
 431                (cffi:with-foreign-slots
 432                    (,slot-names pointer ,struct-lisp-name)
 433                  (make-instance ',struct-lisp-name
 434                                 ,@(loop for slot-name in slot-names
 435                                         for initarg-name in initarg-names
 436                                         for slot-decoder in slot-decoders
 437                                         collect initarg-name
 438                                         if slot-decoder
 439                                         collect `(,slot-decoder ,slot-name)
 440                                         else collect slot-name))))))
 441       (c-write out defclass-form)
 442       (c-write out make-defun-form))))
 443
 444 (define-grovel-syntax cstruct (struct-lisp-name struct-c-name &rest slots)
 445   (let ((documentation (when (stringp (car slots)) (pop slots))))
 446     (c-section-header out "cstruct" struct-lisp-name)
 447     (format out "  CFFI_DEFCSTRUCT_START(~S, ~A, ~A);~%"
 448             (string* struct-lisp-name) struct-c-name
 449             (docstring-to-c documentation))
 450     (dolist (slot slots)
 451       (destructuring-bind (slot-lisp-name slot-c-name &key type (count 1))
 452           slot
 453         (etypecase count
 454           ((eql :auto)
 455            (format out "  CFFI_DEFCSTRUCT_SLOT_AUTO(~A, ~A, ~S, ~S);~%"
 456                    struct-c-name slot-c-name
 457                    (prin1-to-string slot-lisp-name) (prin1-to-string type)))
 458           ((or integer symbol string)
 459            (format out "  CFFI_DEFCSTRUCT_SLOT(~A, ~A, ~S, ~S, ~A);~%"
 460                    struct-c-name slot-c-name
 461                    (prin1-to-string slot-lisp-name) (prin1-to-string type) count)))))
 462     (format out "  CFFI_DEFCSTRUCT_END;~%")
 463     (format out "  CFFI_DEFTYPEDEF(~S, ~S);~%"
 464             (string* struct-lisp-name) (string* :struct))
 465     (format out "  CFFI_DEFTYPESIZE(~S, ~A);~%"
 466             (string* struct-lisp-name) struct-c-name)))
 467
 468 (defun foreign-name-to-symbol (s)
 469   (intern (substitute #\- #\_ (string-upcase s))))
 470
 471 (defun choose-lisp-and-foreign-names (string-or-list)
 472   (etypecase string-or-list
 473     (string (values string-or-list (foreign-name-to-symbol string-or-list)))
 474     (list (destructuring-bind (fname lname &rest args) string-or-list
 475             (declare (ignore args))
 476             (assert (and (stringp fname) (symbolp lname)))
 477             (values fname lname)))))
 478
 479 (define-grovel-syntax cenum (name &rest enum-list)
 480   (let ((documentation (when (stringp (car enum-list)) (pop enum-list))))
 481     (destructuring-bind (name &key (base-type :int) define-constants)
 482         (ensure-list name)
 483       (c-section-header out "cenum" name)
 484       (format out "  CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
 485               (string* name) (prin1-to-string base-type)
 486               (docstring-to-c documentation))
 487       (dolist (enum enum-list)
 488         (destructuring-bind (lisp-name c-name &key documentation)
 489             enum
 490           (check-type lisp-name keyword)
 491           (format out "  CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
 492                   (prin1-to-string lisp-name) c-name
 493                   (docstring-to-c documentation))))
 494       (format out "  CFFI_DEFCENUM_END;~%")
 495       (when define-constants
 496         (define-constants-from-enum out enum-list)))))
 497
 498 (define-grovel-syntax constantenum (name &rest enum-list)
 499   (let ((documentation (when (stringp (car enum-list)) (pop enum-list))))
 500     (destructuring-bind (name &key (base-type :int) define-constants)
 501         (ensure-list name)
 502       (c-section-header out "constantenum" name)
 503       (format out "  CFFI_DEFCENUM_START(~S, ~S, ~A);~%"
 504               (string* name) (prin1-to-string base-type)
 505               (docstring-to-c documentation))
 506       (dolist (enum enum-list)
 507         (destructuring-bind (lisp-name c-name &key documentation optional)
 508             enum
 509           (check-type lisp-name keyword)
 510           (when optional
 511             (format out "#if defined(~A)~%" c-name))
 512           (format out "  CFFI_DEFCENUM_MEMBER(~S, ~A, ~A);~%"
 513                   (prin1-to-string lisp-name) c-name
 514                   (docstring-to-c documentation))
 515           (when optional
 516             (format out "#endif~%"))))
 517       (format out "  CFFI_DEFCENUM_END;~%")
 518       (when define-constants
 519         (define-constants-from-enum out enum-list)))))
 520
 521 (defun define-constants-from-enum (out enum-list)
 522   (dolist (enum enum-list)
 523     (destructuring-bind (lisp-name c-name &key documentation optional)
 524         enum
 525       (process-grovel-form
 526        out `(constant (,lisp-name ,c-name)
 527                       ,@(if documentation (list :documentation t))
 528                       ,@(if optional (list :optional t)))))))
 529 \f
 530
 531 ;;;# Wrapper Generation
 532 ;;;
 533 ;;; Here we generate a C file from a s-exp specification but instead
 534 ;;; of compiling and running it, we compile it as a shared library
 535 ;;; that can be subsequently loaded with LOAD-FOREIGN-LIBRARY.
 536 ;;;
 537 ;;; Useful to get at macro functionality, errno, system calls,
 538 ;;; functions that handle structures by value, etc...
 539 ;;;
 540 ;;; Matching CFFI bindings are generated along with said C file.
 541
 542 (defun process-wrapper-form (out form)
 543   (%process-wrapper-form (form-kind form) out (cdr form)))
 544
 545 ;;; The various operators push Lisp forms onto this list which will be
 546 ;;; written out by PROCESS-WRAPPER-FILE once everything is processed.
 547 (defvar *lisp-forms*)
 548
 549 (defun generate-c-lib-file (input-file output-defaults)
 550   (let ((*lisp-forms* nil)
 551         (c-file (make-pathname :type "c" :defaults output-defaults)))
 552     (with-open-file (out c-file :direction :output :if-exists :supersede)
 553       (with-open-file (in input-file :direction :input)
 554         (write-string *header* out)
 555         (loop for form = (read in nil nil) while form
 556               do (process-wrapper-form out form))))
 557     (values c-file (nreverse *lisp-forms*))))
 558
 559 (defun lib-filename (defaults)
 560   (make-pathname :type (subseq (cffi::default-library-suffix) 1)
 561                  :defaults defaults))
 562
 563 (defun generate-bindings-file (lib-file lib-soname lisp-forms output-defaults)
 564   (let ((lisp-file (tmp-lisp-filename output-defaults)))
 565     (with-open-file (out lisp-file :direction :output :if-exists :supersede)
 566       (format out ";;;; This file was automatically generated by iolib-grovel.~%~
 567                    ;;;; Do not edit by hand.~%")
 568       (let ((*package* (find-package '#:cl))
 569             (named-library-name
 570              (let ((*package* (find-package :keyword))
 571                    (*read-eval* nil))
 572                (read-from-string lib-soname))))
 573         (pprint `(progn
 574                    (cffi:define-foreign-library
 575                        (,named-library-name
 576                         :type :grovel-wrapper
 577                         :search-path ,(directory-namestring lib-file))
 578                      (t ,(namestring (lib-filename lib-soname))))
 579                    (cffi:use-foreign-library ,named-library-name))
 580                 out)
 581         (fresh-line out))
 582       (dolist (form lisp-forms)
 583         (print form out))
 584       (terpri out))
 585     lisp-file))
 586
 587 ;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
 588 ;;; *the extent of a given wrapper file.
 589 (defun process-wrapper-file (input-file output-defaults lib-soname)
 590   (with-standard-io-syntax
 591     (let ((lib-file
 592            (lib-filename (make-pathname :name lib-soname
 593                                         :defaults output-defaults))))
 594       (multiple-value-bind (c-file lisp-forms)
 595           (generate-c-lib-file input-file output-defaults)
 596         (cc-compile-and-link c-file lib-file :library t)
 597         ;; FIXME: hardcoded library path.
 598         (values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults)
 599                 lib-file)))))
 600
 601 (defgeneric %process-wrapper-form (name out arguments)
 602   (:method (name out arguments)
 603     (declare (ignore out arguments))
 604     (error "Unknown Grovel syntax: ~S" name)))
 605
 606 ;;; OUT is lexically bound to the output stream within BODY.
 607 (defmacro define-wrapper-syntax (name lambda-list &body body)
 608   (with-unique-names (name-var args)
 609     `(defmethod %process-wrapper-form ((,name-var (eql ',name)) out ,args)
 610        (declare (ignorable out))
 611        (destructuring-bind ,lambda-list ,args
 612          ,@body))))
 613
 614 (define-wrapper-syntax progn (&rest forms)
 615   (dolist (form forms)
 616     (process-wrapper-form out form)))
 617
 618 (define-wrapper-syntax in-package (name)
 619   (setq *package* (find-package name))
 620   (push `(in-package ,name) *lisp-forms*))
 621
 622 (define-wrapper-syntax c (&rest strings)
 623   (dolist (string strings)
 624     (write-line string out)))
 625
 626 (define-wrapper-syntax flag (&rest flags)
 627   (appendf *cc-flags* (trim-whitespace flags)))
 628
 629 (define-wrapper-syntax proclaim (&rest proclamations)
 630   (push `(proclaim ,@proclamations) *lisp-forms*))
 631
 632 (define-wrapper-syntax declaim (&rest declamations)
 633   (push `(declaim ,@declamations) *lisp-forms*))
 634
 635 (define-wrapper-syntax define (name &optional value)
 636   (format out "#define ~A~@[ ~A~]~%" name value))
 637
 638 (define-wrapper-syntax include (&rest includes)
 639   (format out "~{#include <~A>~%~}" includes))
 640
 641 ;;; FIXME: this function is not complete.  Should probably follow
 642 ;;; typedefs?  Should definitely understand pointer types.
 643 (defun c-type-name (typespec)
 644   (let ((spec (ensure-list typespec)))
 645     (if (stringp (car spec))
 646         (car spec)
 647         (case (car spec)
 648           ((:uchar :unsigned-char) "unsigned char")
 649           ((:unsigned-short :ushort) "unsigned short")
 650           ((:unsigned-int :uint) "unsigned int")
 651           ((:unsigned-long :ulong) "unsigned long")
 652           ((:long-long :llong) "long long")
 653           ((:unsigned-long-long :ullong) "unsigned long long")
 654           (:pointer "void*")
 655           (:string "char*")
 656           (t (cffi::foreign-name (car spec) nil))))))
 657
 658 (defun cffi-type (typespec)
 659   (if (and (listp typespec) (stringp (car typespec)))
 660       (second typespec)
 661       typespec))
 662
 663 (define-wrapper-syntax defwrapper (name-and-options rettype &rest args)
 664   (multiple-value-bind (lisp-name foreign-name options)
 665       (cffi::parse-name-and-options name-and-options)
 666     (let* ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
 667            (fargs (mapcar (lambda (arg)
 668                             (list (c-type-name (second arg))
 669                                   (cffi::foreign-name (first arg) nil)))
 670                           args))
 671            (fargnames (mapcar #'second fargs)))
 672       ;; output C code
 673       (format out "~A ~A" (c-type-name rettype) foreign-name-wrap)
 674       (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
 675       (format out "{~%  return ~A(~{~A~^, ~});~%}~%~%" foreign-name fargnames)
 676       ;; matching bindings
 677       (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
 678                  ,(cffi-type rettype)
 679                ,@(mapcar (lambda (arg)
 680                            (list (cffi::lisp-name (first arg) nil)
 681                                  (cffi-type (second arg))))
 682                          args))
 683             *lisp-forms*))))
 684
 685 (define-wrapper-syntax defwrapper* (name-and-options rettype args &rest c-lines)
 686   ;; output C code
 687   (multiple-value-bind (lisp-name foreign-name options)
 688       (cffi::parse-name-and-options name-and-options)
 689     (let ((foreign-name-wrap (strcat foreign-name "_cffi_wrap"))
 690           (fargs (mapcar (lambda (arg)
 691                            (list (c-type-name (second arg))
 692                                  (cffi::foreign-name (first arg) nil)))
 693                          args)))
 694       (format out "~A ~A" (c-type-name rettype)
 695               foreign-name-wrap)
 696       (format out "(~{~{~A ~A~}~^, ~})~%" fargs)
 697       (format out "{~%~{  ~A~%~}}~%~%" c-lines)
 698       ;; matching bindings
 699       (push `(cffi:defcfun (,foreign-name-wrap ,lisp-name ,@options)
 700                  ,(cffi-type rettype)
 701                ,@(mapcar (lambda (arg)
 702                            (list (cffi::lisp-name (first arg) nil)
 703                                  (cffi-type (second arg))))
 704                          args))
 705             *lisp-forms*))))