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