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