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