cgit.sxemacs.org Git - sxemacs/blob - lisp/ffi.el

   1 ;;; ffi.el --- FFI lisp layer.
   2
   3 ;; Copyright (C) 2005-2010 by Zajcev Evgeny
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Fri Feb 18 18:56:43 MSK 2005
   7 ;; Keywords: lisp, ffi
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not in FSF
  25
  26 ;;; Commentary:
  27
  28 ;;; Types:
  29 ;;
  30 ;; BASIC    ->  byte unsigned-byte .. c-string
  31
  32 ;; ARRAY    ->  (array TYPE SIZE)
  33
  34 ;; STRUCT   ->  (struct name (slot1 TYPE) (slot2 TYPE) .. (slotn TYPE))
  35
  36 ;; UNION    ->  (union name (slot1 TYPE) (slot2 TYPE) .. (slotn TYPE))
  37
  38 ;; FUNCTION -> (function RET-TYPE IN-TYPE .. IN-TYPE)
  39
  40 ;; C:  int a[10] = {1, 2, .. 10};    LISP: [1 2 .. 10]
  41 ;;
  42 ;; C:  struct {                      LISP:  ((i 1) (c ?c))
  43 ;;         int i;
  44 ;;         char c;
  45 ;;     } bb = {1, 'c'};
  46 ;;
  47 ;;; Code:
  48 (eval-when-compile
  49   (globally-declare-boundp
  50    '(ffi-type-checker ffi-named-types ffi-loaded-libraries))
  51   (globally-declare-fboundp
  52    '(ffi-size-of-type make-ffi-object ffi-canonicalise-type
  53                       ffi-basic-type-p ffi-load-library ffi-dlerror
  54                       ffi-object-type ffi-fetch ffi-slot-offset
  55                       ffi-store ffi-aref ffi-make-pointer
  56                       ffi-object-address ffi-call-function
  57                       ffi-defun ffi-bind)))
  58
  59 \f
  60 (require 'alist)
  61
  62 (setq ffi-type-checker #'ffi-type-p)
  63
  64 (defun ffi-create-fo (type val)
  65   "Create a foreign object of TYPE and set its value to VAL.
  66 Return created FFI object."
  67   (let* ((ctype (ffi-canonicalise-type type))
  68          (size (cond ((or (eq ctype 'c-string) (eq ctype 'c-data))
  69                       (1+ (length val)))
  70                      ((and (consp ctype) (eq (car ctype) 'c-data)
  71                            (intp (cdr ctype)))
  72                       (cdr ctype))
  73                      (t
  74                       (ffi-size-of-type ctype))))
  75          (fo (make-ffi-object type size)))
  76     (ffi-set fo val)
  77     fo))
  78
  79 (defun ffi-find-named-type (type-name)
  80   "Search for TYPE-NAME in named FFI types."
  81   (cdr (assq type-name ffi-named-types)))
  82
  83 (defmacro declare-ffi-type (name)
  84   `(put (quote ,name) 'declared-ffi-type t))
  85
  86 (defmacro ffi-declared-type-p (name)
  87   `(and (symbolp ,name) (get ,name 'declared-ffi-type)))
  88 (defsetf ffi-declared-type-p (name) (val)
  89   `(and (symbolp ,name) (put ,name 'declared-ffi-type ,val)))
  90
  91 ;; Null pointer
  92 (defun ffi-null-pointer ()
  93   "Return null-pointer."
  94   (ffi-make-pointer 0))
  95
  96 (defun ffi-null-p (ptr)
  97   "Return non-nil if PTR is null pointer."
  98   (zerop (ffi-pointer-address ptr)))
  99
 100 ;;; Type translators
 101 (defvar ffi-type-to-translators nil)
 102 (defvar ffi-type-from-translators nil)
 103
 104 (defmacro define-ffi-translator (translators type body)
 105   `(pushnew (cons ,type '(progn ,@body)) ,translators :key #'car))
 106
 107 (defmacro define-ffi-translator-to-foreign (type &rest body)
 108   "Define translator to foreign type for TYPE.
 109 BODY should use `value' to reference typed value."
 110   `(define-ffi-translator ffi-type-to-translators ',type ,body))
 111
 112 (defmacro define-ffi-translator-from-foreign (type &rest body)
 113   "Define translator from foreign type for TYPE.
 114 BODY should use `value' to reference typed value."
 115   `(define-ffi-translator ffi-type-from-translators ',type ,body))
 116
 117 (defmacro ffi-translate-foreign (value type translators)
 118   `(let ((translator (assq ,type ,translators)))
 119      (if translator
 120          (eval (cdr translator))
 121        value)))
 122
 123 (defun ffi-translate-to-foreign (value type)
 124   (ffi-translate-foreign value type ffi-type-to-translators))
 125
 126 (defun ffi-translate-from-foreign (value type)
 127   (ffi-translate-foreign value type ffi-type-from-translators))
 128
 129 ;;;###autoload
 130 (defun ffi-define-type-internal (name type)
 131   (when (and name (ffi-find-named-type name))
 132     (warn "Already defined NAME" name))
 133
 134   (unless (and name (ffi-find-named-type name))
 135     (when (ffi-declared-type-p name)
 136       (setf (ffi-declared-type-p name) nil))
 137
 138     ;; Try to get name from union or struct
 139     (when (and (null name)
 140                (listp type)
 141                (memq (car type) '(struct union)))
 142       (setq name (cadr type)))
 143
 144     (setq ffi-named-types
 145           (put-alist name type ffi-named-types))
 146
 147     ;; Copy translators, if any
 148     (let ((fft (assq type ffi-type-to-translators))
 149           (tft (assq type ffi-type-from-translators)))
 150       (when fft
 151         (pushnew (cons name (cdr fft)) ffi-type-to-translators :key #'car))
 152       (when tft
 153         (pushnew (cons name (cdr tft)) ffi-type-from-translators :key #'car)))
 154
 155     name))
 156
 157 (defmacro define-ffi-type (name type)
 158   "Associate NAME with FFI TYPE.
 159 When defining global structures or unions, NAME may be
 160 nil, in that case NAME is derived from the name of
 161 TYPE."
 162   `(ffi-define-type-internal ',name ',type))
 163
 164 (defmacro define-ffi-struct (name &rest slots)
 165   "Define a new structure of NAME and SLOTS.
 166 SLOTS are in form (NAME TYPE &key :offset)."
 167   (let ((forms `(progn
 168                   (define-ffi-type ,name (struct ,name ,@slots)))))
 169     (loop for sn in slots
 170       do (setq sn (car sn))
 171       do (let ((sym (intern (format "%S->%S" name sn))))
 172            (setq forms (append forms
 173                                `((defun ,sym (obj)
 174                                    (ffi-fetch obj (ffi-slot-offset ',name ',sn)
 175                                               (ffi-slot-type ',name ',sn))))))
 176            (setq forms
 177                  (append forms
 178                          `((defsetf ,sym (obj) (nv)
 179                              (list 'ffi-store obj
 180                                    (list 'ffi-slot-offset '',name '',sn)
 181                                    (list 'ffi-slot-type '',name '',sn)
 182                                    nv)))))))
 183     forms))
 184
 185 ;;;###autoload
 186 (defun ffi-type-p (type &optional signal-p)
 187   "Return non-nil if TYPE is a valid FFI type.
 188 If optional argument SIGNAL-P is non-nil and TYPE is not an
 189 FFI type, additionally signal an error.
 190
 191 NOTE: returned non-nil value is actuall canonicalised type."
 192   (setq type (ffi-canonicalise-type type))
 193   (if (cond ((ffi-basic-type-p type) type)
 194
 195             ;; Pointer
 196             ((or (eq type 'pointer)
 197                  (and (listp type)
 198                       (eq (car type) 'pointer)
 199                       (ffi-type-p (cadr type)))) type)
 200
 201             ;; Maybe TYPE is declared
 202             ((ffi-declared-type-p type) type)
 203
 204             ;; Struct or Union
 205             ((and (listp type)
 206                   (memq (car type) '(struct union)))
 207              type)
 208 ;             (not (memq nil
 209 ;                        (mapcar #'(lambda (slot-type)
 210 ;                                    (ffi-type-p (cadr slot-type)))
 211 ;                                (cddr type)))))
 212
 213             ;; Complex c-data
 214             ((and (consp type) (eq (car type) 'c-data)
 215                   (or (numberp (cdr type)) (null (cdr type))))
 216              type)
 217
 218             ;; Array
 219             ((and (listp type) (eq 'array (car type))
 220                   (ffi-type-p (cadr type))
 221                   (integerp (caddr type))
 222                   (> (caddr type) 0))
 223              type)
 224
 225             ;; Function
 226             ((and (listp type) (eq 'function (car type))
 227                   (ffi-type-p (cadr type)))
 228              (not (memq nil (mapcar 'ffi-type-p (cddr type))))))
 229       type                              ; TYPE is valid FFI type
 230
 231     (when signal-p
 232       (signal-error 'invalid-argument type))))
 233
 234 ;;;###autoload
 235 (defun ffi-load (libname)
 236   "Load library LIBNAME.
 237 Return a foreign object handle if successful, or indicate an error if
 238 the library cannot be loaded.
 239
 240 The argument LIBNAME should be the file-name string of a shared
 241 object library (usual extension is `.so').
 242
 243 The library should reside in one of the directories specified by the
 244 $LD_LIBRARY_PATH environment variable or the more global ld.so.cache."
 245   (let ((fo (ffi-load-library libname)))
 246     (unless fo
 247       (error "Can't load library `%s': %s" libname (ffi-dlerror)))
 248
 249     (setq ffi-loaded-libraries
 250           (put-alist libname fo ffi-loaded-libraries))
 251     fo))
 252
 253 (defun* ffi-get (fo &key (type (ffi-object-type fo)) (off 0)
 254                     (from-call nil))
 255   "Return FO's value.
 256 Optional key :TYPE may be used to cast FO to the specified
 257 type, it defaults to the object's assigned type.
 258 Optional key :OFF may be used to specify an offset, it
 259 defaults to 0.
 260 FROM-CALL is magic, do not use it!"
 261   (let ((ctype (ffi-canonicalise-type type)))
 262     (cond ((ffi-basic-type-p ctype)
 263            (ffi-fetch fo off type))
 264           ;; Arrays
 265           ((and (listp ctype)
 266                 (eq (car ctype) 'array))
 267            (vconcat
 268             (loop for idx from 0 below (third ctype)
 269               collect (ffi-get
 270                        fo :type (second ctype)
 271                        :off (+ off (* idx (ffi-size-of-type
 272                                            (second ctype))))))))
 273
 274           ;; Structures
 275           ((and (listp ctype)
 276                 (eq (car ctype) 'struct))
 277            (loop for sslot in (cddr ctype)
 278              collect (list (first sslot)
 279                            (ffi-get
 280                             fo :type (second sslot)
 281                             :off (+ off (ffi-slot-offset
 282                                          ctype (first sslot)))))))
 283
 284           ;; Extremely special case for safe-string!
 285           ((eq type 'safe-string)
 286            (unless (ffi-null-p fo)
 287              (ffi-fetch fo off 'c-string)))
 288
 289           ((and (not from-call)
 290                 (or (eq ctype 'pointer)
 291                     (and (listp ctype)
 292                          (eq (car ctype) 'pointer)
 293                          (ffi-type-p (cadr ctype)))))
 294            (if (ffi-null-p fo)
 295                nil
 296              (ffi-fetch fo off type)))
 297
 298           (t
 299            ;; Can't get value in proper form,
 300            ;; just return FO unmodified
 301            fo))))
 302
 303 (defun ffi-slot-type (type slot)
 304   "Return TYPE's SLOT type.
 305 TYPE must be of structure or union type."
 306   (let ((ctype (ffi-canonicalise-type type)))
 307     (unless (memq (car ctype) '(struct union))
 308       (error "Not struct or union: %S" type))
 309     (or (cadr (find slot (cddr ctype) :key #'car :test #'eq))
 310         (error "No such slot: %S" slot))))
 311
 312 (defun ffi-slot (fo slot)
 313   "Setf-able slot accessor.
 314 Return FO's SLOT value.  Can be used in conjunction with `setf' to set
 315 FO's SLOT."
 316   ;; Note: `ffi-slot-offset' checks for struct or union type.
 317   (let ((soff (ffi-slot-offset (ffi-object-type fo) slot)))
 318     (ffi-fetch fo soff (ffi-slot-type (ffi-object-type fo) slot))))
 319
 320 (defsetf ffi-slot (fo slot) (val)
 321   `(let ((soff (ffi-slot-offset (ffi-object-type ,fo) ,slot)))
 322     (ffi-store ,fo soff (ffi-slot-type (ffi-object-type ,fo) ,slot) ,val)))
 323
 324 (defun ffi-set (fo val)
 325   "Set FO's foreign value to VAL."
 326   (let* ((type (ffi-object-type fo))
 327          (ctype (ffi-canonicalise-type type)))
 328     (if (or (ffi-basic-type-p ctype)
 329             (eq ctype 'pointer))
 330         (ffi-store fo 0 type val)
 331
 332       ;; Pointer type, same as for basic
 333       (when (or (eq ctype 'pointer)
 334                 (and (listp ctype) (eq (car ctype) 'pointer)))
 335         (ffi-store fo 0 type val))
 336
 337       ;; TODO: Compound type
 338       )))
 339
 340 ;; Dereferencing a pointer is done with aref (lg told me), however I
 341 ;; find it misleading, so ...
 342 (defun ffi-deref (fo-pointer)
 343   "Return the data FO-POINTER points to.
 344 This is the equivalent of the `*' operator in C.
 345 Error will be signaled if FO-POINTER is not of pointer type."
 346   (ffi-aref fo-pointer 0))
 347
 348 (defmacro define-ffi-function (fsym args doc-string ftype ename)
 349   "Define ffi function visible from Emacs lisp as FSYM."
 350   `(defun ,fsym ,args ,doc-string
 351     (ffi-get (ffi-call-function (load-time-value (ffi-defun ,ftype ,ename))
 352                                 ,@(mapcar* #'(lambda (type arg)
 353                                                `(if (ffi-object-p ,arg)
 354                                                     ,arg
 355                                                   (ffi-create-fo ',type ,arg)))
 356                                            (cddadr ftype) args))
 357
 358              :from-call t)))
 359 (put 'define-ffi-function 'lisp-indent-function 'defun)
 360
 361 \f
 362 ;;; helpers
 363
 364 (defmacro ffi-enum (name &optional docstring &rest specs)
 365   "Define an enumeration NAME.
 366 Optional argument DOCSTRING is a documentation string.
 367
 368 SPECS can be an arbitrary number of symbols which will be enumerated in
 369 the respective order.
 370
 371 Additionally the cells of SPECS may look like
 372
 373   foo = bar
 374
 375 to adhere a symbol `foo' to the enumeration with the value of the
 376 symbol `bar' \(i.e. `foo' is an alias of `bar'\).
 377
 378 Moreover, it is possible to set the counter explicitly:
 379
 380   baz = 5
 381
 382 would assign a value of 5 to the symbol `baz' and \(by side-effect\)
 383 set the counter to 6 for the next symbol.
 384
 385 The defined enumeration will result in a \(defconst'd\) variable `NAME',
 386 the value is an alist of the form \(\(symbol . value\) ...\), where
 387 `value' is the C-value of `symbol'.
 388
 389 Furthermore, two functions \(named `NAME' and `NAME'-value\) will be
 390 defined.  The first one is a simple lookup function returning the
 391 C-value of a passed symbol.  The second does basically the same
 392 but returns the representing \(elisp\) integer of a symbol.
 393 Both functions return nil if the symbol is not in the enumeration."
 394
 395   ;; first check if we were passed a docstring
 396   (unless (stringp docstring)
 397     ;; docstring is missing, the value of docstring already
 398     ;; contains the first symbol, hence we pump that one to specs
 399     (unless (null docstring)
 400       (setq specs (cons docstring specs)))
 401     (setq docstring (format "Enumeration `%s'" name)))
 402
 403   ;; now build that pig of code
 404   (list 'prog1
 405         ;; define the constant `name'
 406         (list 'defconst name nil
 407               docstring)
 408         ;; fill in the values
 409         (list 'setq name
 410               (cons 'list
 411                     (let ((tmpspecs specs)
 412                           (i 0)
 413                           (delayed (dllist))
 414                           (result (dllist)))
 415                       (while (car tmpspecs)
 416                         (if (eq (cadr tmpspecs) '=)
 417                             ;; this is the alias case
 418                             ;; we append a cons (left-of-= . right-of-=)
 419                             ;; to the dllist `delayed'
 420                             ;; if `right-of-=' (i.e. the caddr) is an integer
 421                             ;; we set the counter `i' to that value on go on
 422                             ;; from there
 423                             (let ((leftof (car tmpspecs))
 424                                   (rightof (caddr tmpspecs)))
 425
 426                               ;; pop off the cruft
 427                               (setq tmpspecs (nthcdr 3 tmpspecs))
 428
 429                               (cond ((intp rightof)
 430                                      ;; reset the counter
 431                                      (setq i rightof)
 432                                      ;; prepend leftof again
 433                                      (setq tmpspecs
 434                                            (cons leftof tmpspecs)))
 435                                     (t
 436                                      ;; push the stuff to the delayed list
 437                                      (dllist-append
 438                                       delayed (cons leftof rightof)))))
 439
 440                           ;; ordinary case
 441                           (dllist-append result (cons (car tmpspecs) i))
 442                           (setq i (1+ i))
 443                           (setq tmpspecs (cdr tmpspecs))))
 444
 445                       ;; convert `result' to alist
 446                       ;; this is necessary here, since we need the alist
 447                       ;; property right now to look up the delayed symbols
 448                       (setq result (dllist-to-list result))
 449
 450                       ;; process those delayed thingies
 451                       ;; these are basically conses (alias . resolved-symbol)
 452                       ;; we lookup `resolved-symbol' in the alist `result'
 453                       ;; first and assign (alias . value-of-resolved-symbol)
 454                       ;; if that fails, we look at the cars of the delayed
 455                       ;; list if we can find `resolved-symbol' there
 456                       ;; if so, we re-append the whole cell to the delayed list
 457                       ;; if not, we try to find a huge horsewhip to treat
 458                       ;; the user to a little surprise :)
 459                       (while (dllist-car delayed)
 460                         (let ((alias (dllist-pop-car delayed)))
 461                           (let ((val (cdr-safe (assoc (cdr alias) result))))
 462                             (if (null val)
 463                                 ;; prevent infinite loops when the user
 464                                 ;; is too stupid to give us a valid alias
 465                                 (when (let ((presentp))
 466                                         (mapc-internal
 467                                          #'(lambda (item)
 468                                              (and (eq (cdr alias) (car item))
 469                                                   (setq presentp t)))
 470                                          delayed)
 471                                         presentp)
 472                                     (dllist-append delayed alias))
 473                               (setq result
 474                                     (cons (cons (car alias) val)
 475                                           result))))))
 476
 477                       ;; return `result'
 478                       (mapcar
 479                        #'(lambda (rescell)
 480                            (list 'cons
 481                                  (list 'quote (car rescell))
 482                                  (list
 483                                   'let
 484                                   (list (list 'ffival
 485                                               (list 'ffi-create-fo
 486                                                     ''unsigned-int
 487                                                     (cdr rescell))))
 488                                   (list 'put 'ffival ''value (cdr rescell))
 489                                   'ffival)))
 490                        result))))
 491
 492         ;; define the lookup function
 493         (list 'defun name '(symbol)
 494               (format "Lookup the value of SYMBOL in the enumeration `%s'."
 495                       name)
 496               (list 'cdr-safe
 497                     (list 'assq 'symbol
 498                           name)))
 499
 500         ;; define the lookup function for the elisp value
 501         (list 'defun (intern (format "%s-value" name)) '(symbol)
 502               (format (concat "Lookup the elisp value (an integer) of SYMBOL "
 503                               "in the enumeration `%s'.")
 504                       name)
 505               (list 'get (list name 'symbol) ''value))))
 506 (put 'ffi-enum 'lisp-indent-function 'defun)
 507 ;;; example
 508 ;; (ffi-enum example-enum
 509 ;;   ;;"Enum of control commands."
 510 ;;   test_thing = symbol_1
 511 ;;   symbol_0
 512 ;;   symbol_1
 513 ;;   foobbbbar = test_thing
 514 ;;   snaabar = foobbbbar
 515 ;;   go-on-with5 = 5
 516 ;;   guesswhat)
 517 ;; (example-enum-value 'guesswhat)
 518
 519 (defmacro define-ffi-enum (type-name &rest spec)
 520   "Create enumarate type which you can pass to C functions.
 521 For example:
 522   \(define-ffi-enum MyEnum
 523     \(Boris 0\)
 524     Vova
 525     Micha\)"
 526   `(progn
 527      (define-ffi-type ,type-name int)
 528      (let* ((cv 0)
 529             (fev (mapcar #'(lambda (sv)
 530                              (prog1
 531                                  (if (and (listp sv)
 532                                           (symbolp (car sv))
 533                                           (numberp (cadr sv)))
 534                                      (prog1
 535                                          (cons (car sv) (cadr sv))
 536                                        (setq cv (cadr sv)))
 537                                    (cons sv cv))
 538                                (incf cv)))
 539                          '(,@spec))))
 540        (put ',type-name 'ffi-enum-values fev))
 541      ;; Translators
 542      (define-ffi-translator-to-foreign ,type-name
 543        (or (cdr (assq value (get ',type-name 'ffi-enum-values)))
 544            0))
 545      (define-ffi-translator-from-foreign ,type-name
 546        (or (car (find-if #'(lambda (v)
 547                              (= (cdr v) value))
 548                          (get ',type-name 'ffi-enum-values)))
 549            'undefined-enum-value))))
 550
 551 (defun ffi-enum-values (enum-type)
 552   "Return alist for ENUM-TYPE.
 553 Where car is symbol and cdr is the numeric value for it."
 554   (get enum-type 'ffi-enum-values))
 555
 556 ;;; Callbacks
 557 (defmacro define-ffi-callback (sym retype args &rest body)
 558   "Create new callback to be called from C.
 559 Return foreign object that you can pass as callback to some C
 560 function.
 561
 562 For example:
 563
 564 \(define-ffi-callback my-nice-cb int
 565   \(\(proname c-string\) \(event pointer\)\)
 566   \"Print nice message in the minibuffer and return 10000.\"
 567   \(message \"nice message\"\)
 568   10000\)
 569
 570 To get foreign object for this callback function use `ffi-callback-fo'
 571 and pass the name of the callback."
 572   (let ((argnames (mapcar #'first args))
 573         (argtypes (mapcar #'second args)))
 574   `(progn
 575      (defun ,sym ,argnames
 576        ,@body)
 577      (let ((cfo (ffi-make-callback ',sym ',retype ',argtypes 0)))
 578        (put ',sym 'ffi-callback-fo cfo)
 579        cfo))))
 580
 581 (put 'define-ffi-callback 'lisp-indent-function 'defun)
 582
 583 (defmacro ffi-callback-fo (sym)
 584   "Return SYM callback's foreign object."
 585   `(get ,sym 'ffi-callback-fo))
 586
 587 \f
 588 ;; Define some types
 589 (define-ffi-type boolean int)
 590 (define-ffi-translator-to-foreign boolean
 591   (if value 1 0))
 592 (define-ffi-translator-from-foreign boolean
 593   (not (zerop value)))
 594
 595 (define-ffi-type lisp-object pointer)
 596 (define-ffi-translator-to-foreign lisp-object
 597   (ffi-lisp-object-to-pointer value))
 598 (define-ffi-translator-from-foreign lisp-object
 599   (ffi-pointer-to-lisp-object value))
 600
 601 ;; NOTE: use only for return values
 602 (define-ffi-type safe-string pointer)
 603
 604 (define-ffi-type callback pointer)
 605 (define-ffi-translator-to-foreign callback
 606   (ffi-callback-fo value))
 607
 608 \f
 609 ;;; CFFI
 610 (define-ffi-type :byte byte)
 611 (define-ffi-type :unsigned-byte unsigned-byte)
 612 (define-ffi-type :char char)
 613 (define-ffi-type :unsigned-char unsigned-char)
 614 (define-ffi-type :uchar unsigned-char)
 615 (define-ffi-type :short short)
 616 (define-ffi-type :unsigned-short unsigned-short)
 617 (define-ffi-type :ushort unsigned-short)
 618 (define-ffi-type :int int)
 619 (define-ffi-type :unsigned-int unsigned-int)
 620 (define-ffi-type :uint unsigned-int)
 621 (define-ffi-type :long long)
 622 (define-ffi-type :unsigned-long unsigned-long)
 623 (define-ffi-type :ulong unsigned-long)
 624 (define-ffi-type :float float)
 625 (define-ffi-type :double double)
 626 (define-ffi-type :void void)
 627 (define-ffi-type :pointer pointer)
 628 (define-ffi-type :boolean boolean)
 629 (define-ffi-type :string c-string)
 630
 631 ;;;# Accessing Foreign Globals
 632
 633 (defun cffi:lisp-var-name (name &optional fun-p)
 634   "Return the Lisp symbol for foreign var NAME."
 635   (etypecase name
 636     (list (second name))
 637     (string (intern (format "%s%s%s" (if fun-p "" "*")
 638                             (downcase (substitute ?- ?_ name)) (if fun-p "" "*"))))
 639     (symbol name)))
 640
 641 (defun cffi:foreign-var-name (name)
 642   "Return the foreign var name of NAME."
 643   (etypecase name
 644     (list (first name))
 645     (string name)
 646     (symbol (let ((dname (downcase (symbol-name name))))
 647               (replace-in-string (substitute ?_ ?- dname) "\\*" "")))))
 648
 649 (defun cffi:get-var-pointer (symbol)
 650   "Return a pointer to the foreign global variable relative to SYMBOL."
 651   (cffi:foreign-symbol-pointer (get symbol 'foreign-var-name)))
 652
 653 (defmacro cffi:defcstruct (name &rest args)
 654   `(define-ffi-struct ,name ,@args))
 655
 656 (defmacro cffi:defcvar (name type)
 657   (let ((ns (cffi:lisp-var-name name)))
 658     `(defvar ,ns (ffi-bind ,type (cffi:foreign-var-name ',name)))))
 659
 660 (defmacro cffi:defcfun (name ret-type &optional docstring &rest in-args)
 661   ;; First check if we were passed a docstring
 662   (unless (stringp docstring)
 663     ;; docstring is missing, the value of docstring already contains
 664     ;; the first argument, hence we pump that one to in-args
 665     (unless (null docstring)
 666       (setq in-args (cons docstring in-args)))
 667     (setq docstring
 668           (format "Lisp variant for `%s' foreign function."
 669                   (cffi:foreign-var-name name))))
 670
 671   (let* ((nsl (cffi:lisp-var-name name t))
 672          (nsf (cffi:foreign-var-name name))
 673          (with-rest (when (eq (car (last in-args)) '&rest)
 674                       (setq in-args (butlast in-args))
 675                       t))
 676          (as (mapcar 'first in-args))
 677          (at (mapcar 'second in-args))
 678          (flet-form) (defun-form nil))
 679     (setq flet-form
 680           (append (list `(mapcar* #'setarg ',at (list ,@as)))
 681                   (when with-rest
 682                     (list '(while rest-args
 683                              (if (ffi-object-p (car rest-args))
 684                                  (progn
 685                                    (setarg (ffi-object-type (car rest-args))
 686                                            (car rest-args))
 687                                    (setq rest-args (cdr rest-args)))
 688                              (setarg (car rest-args) (cadr rest-args))
 689                              (setq rest-args (cddr rest-args))))))
 690                   (list '(setq ffiargs (nreverse ffiargs)))
 691                   (list `(setq ret (apply #'ffi-call-function
 692                                           (get ',nsl 'ffi-fun) ffiargs)))
 693                   (list `(ffi-get ret :from-call t))))
 694     (setq defun-form
 695           (append `(defun ,nsl)
 696                   (list (if with-rest
 697                             (append as '(&rest rest-args))
 698                           as))
 699                   (list docstring)
 700                   (list (append
 701                          '(let (ffiargs ret))
 702                          (list (append
 703                                 '(flet ((setarg (type arg)
 704                                           (setq ffiargs
 705                                                 (cons
 706                                                  (if (ffi-object-p arg)
 707                                                      arg
 708                                                    (ffi-create-fo type arg))
 709                                                  ffiargs)))))
 710                                 flet-form))
 711                          ))))
 712     (append '(progn) (list defun-form)
 713             (list `(put ',nsl 'ffi-fun
 714                         (ffi-defun '(function ,ret-type ,@at) ,nsf))))))
 715
 716 (put 'cffi:defcfun 'lisp-indent-function 'defun)
 717
 718 (defun ffi:canonicalize-symbol-name-case (name)
 719   (upcase name))
 720
 721 ;;;# Allocation
 722
 723 (defun cffi:foreign-alloc (type)
 724   "Return pointer."
 725   (ffi-call-function
 726    (ffi-defun '(function pointer unsigned-int) "malloc")
 727    (ffi-create-fo 'unsigned-int (ffi-size-of-type type))))
 728
 729 (defun cffi:foreign-free (ptr)
 730   "Frees a PTR previously allocated with `cffi:foreign-alloc'."
 731   (ffi-call-function
 732    (ffi-defun '(function void pointer) "free")
 733    ptr))
 734
 735 (defmacro cffi:with-foreign-pointer (spec &rest body)
 736   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 737 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 738 may be stack-allocated if supported by the implementation.  If
 739 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 740   (let ((var (car spec))
 741         (size (cadr spec))
 742         (size-var (caddr spec)))
 743     (unless size-var
 744       (setf size-var (gensym "SIZE")))
 745     `(let* ((,size-var ,size)
 746             (,var (cffi:foreign-alloc ,size-var)))
 747        (unwind-protect
 748            (progn ,@body)
 749          (cffi:foreign-free ,var)))))
 750
 751 ;;;# Misc. Pointer Operations
 752
 753 (defun ffi-pointer-p (fo)
 754   "Return non-nil if ffi objct FO has pointer type."
 755   (let ((ctype (ffi-canonicalise-type (ffi-object-type fo))))
 756     (or (eq ctype 'pointer)
 757         (and (listp ctype)
 758              (eq (car ctype) 'pointer)
 759              (ffi-type-p (cadr ctype))))))
 760
 761 (defalias 'cffi:make-pointer 'ffi-make-pointer)
 762 (defalias 'ffi-pointer-address 'ffi-object-address)
 763 (defalias 'cffi:pointer-address 'ffi-pointer-address)
 764 (defalias 'cffi:pointerp 'ffi-pointer-p)
 765 (defalias 'cffi:null-pointer 'ffi-null-pointer)
 766 (defalias 'cffi:null-pointer-p 'ffi-null-p)
 767
 768 (defun cffi:inc-pointer (ptr offset)
 769   "Return a pointer OFFSET bytes past PTR."
 770   (ffi-make-pointer (+ (ffi-object-address ptr) offset)))
 771
 772 (defun cffi:pointer-eq (ptr1 ptr2)
 773   "Return true if PTR1 and PTR2 point to the same address."
 774   (= (ffi-object-address ptr1) (ffi-object-address ptr2)))
 775
 776 ;;;# Dereferencing
 777
 778 (defun* cffi:mem-ref (ptr type &optional (offset 0))
 779   "Dereference an object of TYPE at OFFSET bytes from PTR."
 780   (ffi-fetch ptr offset type))
 781
 782 ; (defun cffi:%mem-set (value ptr type &optional (offset 0))
 783 ;   "Set an object of TYPE at OFFSET bytes from PTR."
 784 ;   (let* ((type (convert-foreign-type type))
 785 ;          (type-size (ffi:size-of-foreign-type type)))
 786 ;     (si:foreign-data-set-elt
 787 ;      (si:foreign-data-recast ptr (+ offset type-size) :void)
 788 ;      offset type value)))
 789
 790 ;;;# Type Operations
 791
 792 (defalias 'cffi:foreign-type-size 'ffi-size-of-type)
 793 (defalias 'cffi:foreign-type-alignment 'ffi-type-alignment)
 794
 795 (defalias 'cffi:load-foreign-library 'ffi-load)
 796
 797 ;;;# Callbacks
 798 (defmacro cffi:%defcallback (name rettype arg-names arg-types &rest body)
 799   `(define-ffi-callback ,name ,rettype ,(mapcar* #'list arg-names arg-types)
 800      ,@body))
 801
 802 (put 'cffi:%defcallback 'lisp-indent-function 'defun)
 803
 804 (defmacro cffi:%callback (name)
 805   `(ffi-callback-fo ,name))
 806
 807 ;;;# Foreign Globals
 808
 809 (defun cffi:foreign-symbol-pointer (name)
 810   "Returns a pointer to a foreign symbol NAME."
 811   (ffi-bind 'pointer name))
 812
 813 ;;;# Finalizers
 814
 815 (defun cffi:finalize (object function)
 816   (error "SXEmacs FFI does not support finalizers."))
 817
 818 (defun cffi:cancel-finalization (object)
 819   (error "SXEmacs FFI does not support finalizers."))
 820
 821 (provide 'ffi)
 822
 823 ;;; ffi.el ends here