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