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   `(progn
 351      (declare (special ,fsym))
 352      (setq ,fsym (ffi-defun ,ftype ,ename))
 353      (defun ,fsym ,args
 354        ,doc-string
 355        (let ((ffiargs nil)
 356              (ret nil))
 357          (mapcar* #'(lambda (type arg)
 358                       (setq ffiargs (cons
 359                                      (if (ffi-object-p arg)
 360                                          arg
 361                                        (ffi-create-fo type arg))
 362                                      ffiargs)))
 363                   (cddr ,ftype) (list ,@args))
 364          (setq ffiargs (nreverse ffiargs))
 365          (setq ret (apply #'ffi-call-function ,fsym ffiargs))
 366          (ffi-get ret :from-call t)))))
 367
 368 (put 'define-ffi-function 'lisp-indent-function 'defun)
 369
 370 \f
 371 ;;; helpers
 372
 373 (defmacro ffi-enum (name &optional docstring &rest specs)
 374   "Define an enumeration NAME.
 375 Optional argument DOCSTRING is a documentation string.
 376
 377 SPECS can be an arbitrary number of symbols which will be enumerated in
 378 the respective order.
 379
 380 Additionally the cells of SPECS may look like
 381
 382   foo = bar
 383
 384 to adhere a symbol `foo' to the enumeration with the value of the
 385 symbol `bar' \(i.e. `foo' is an alias of `bar'\).
 386
 387 Moreover, it is possible to set the counter explicitly:
 388
 389   baz = 5
 390
 391 would assign a value of 5 to the symbol `baz' and \(by side-effect\)
 392 set the counter to 6 for the next symbol.
 393
 394 The defined enumeration will result in a \(defconst'd\) variable `NAME',
 395 the value is an alist of the form \(\(symbol . value\) ...\), where
 396 `value' is the C-value of `symbol'.
 397
 398 Furthermore, two functions \(named `NAME' and `NAME'-value\) will be
 399 defined.  The first one is a simple lookup function returning the
 400 C-value of a passed symbol.  The second does basically the same
 401 but returns the representing \(elisp\) integer of a symbol.
 402 Both functions return nil if the symbol is not in the enumeration."
 403
 404   ;; first check if we were passed a docstring
 405   (unless (stringp docstring)
 406     ;; docstring is missing, the value of docstring already
 407     ;; contains the first symbol, hence we pump that one to specs
 408     (unless (null docstring)
 409       (setq specs (cons docstring specs)))
 410     (setq docstring (format "Enumeration `%s'" name)))
 411
 412   ;; now build that pig of code
 413   (list 'prog1
 414         ;; define the constant `name'
 415         (list 'defconst name nil
 416               docstring)
 417         ;; fill in the values
 418         (list 'setq name
 419               (cons 'list
 420                     (let ((tmpspecs specs)
 421                           (i 0)
 422                           (delayed (dllist))
 423                           (result (dllist)))
 424                       (while (car tmpspecs)
 425                         (if (eq (cadr tmpspecs) '=)
 426                             ;; this is the alias case
 427                             ;; we append a cons (left-of-= . right-of-=)
 428                             ;; to the dllist `delayed'
 429                             ;; if `right-of-=' (i.e. the caddr) is an integer
 430                             ;; we set the counter `i' to that value on go on
 431                             ;; from there
 432                             (let ((leftof (car tmpspecs))
 433                                   (rightof (caddr tmpspecs)))
 434
 435                               ;; pop off the cruft
 436                               (setq tmpspecs (nthcdr 3 tmpspecs))
 437
 438                               (cond ((intp rightof)
 439                                      ;; reset the counter
 440                                      (setq i rightof)
 441                                      ;; prepend leftof again
 442                                      (setq tmpspecs
 443                                            (cons leftof tmpspecs)))
 444                                     (t
 445                                      ;; push the stuff to the delayed list
 446                                      (dllist-append
 447                                       delayed (cons leftof rightof)))))
 448
 449                           ;; ordinary case
 450                           (dllist-append result (cons (car tmpspecs) i))
 451                           (setq i (1+ i))
 452                           (setq tmpspecs (cdr tmpspecs))))
 453
 454                       ;; convert `result' to alist
 455                       ;; this is necessary here, since we need the alist
 456                       ;; property right now to look up the delayed symbols
 457                       (setq result (dllist-to-list result))
 458
 459                       ;; process those delayed thingies
 460                       ;; these are basically conses (alias . resolved-symbol)
 461                       ;; we lookup `resolved-symbol' in the alist `result'
 462                       ;; first and assign (alias . value-of-resolved-symbol)
 463                       ;; if that fails, we look at the cars of the delayed
 464                       ;; list if we can find `resolved-symbol' there
 465                       ;; if so, we re-append the whole cell to the delayed list
 466                       ;; if not, we try to find a huge horsewhip to treat
 467                       ;; the user to a little surprise :)
 468                       (while (dllist-car delayed)
 469                         (let ((alias (dllist-pop-car delayed)))
 470                           (let ((val (cdr-safe (assoc (cdr alias) result))))
 471                             (if (null val)
 472                                 ;; prevent infinite loops when the user
 473                                 ;; is too stupid to give us a valid alias
 474                                 (when (let ((presentp))
 475                                         (mapc-internal
 476                                          #'(lambda (item)
 477                                              (and (eq (cdr alias) (car item))
 478                                                   (setq presentp t)))
 479                                          delayed)
 480                                         presentp)
 481                                     (dllist-append delayed alias))
 482                               (setq result
 483                                     (cons (cons (car alias) val)
 484                                           result))))))
 485
 486                       ;; return `result'
 487                       (mapcar
 488                        #'(lambda (rescell)
 489                            (list 'cons
 490                                  (list 'quote (car rescell))
 491                                  (list
 492                                   'let
 493                                   (list (list 'ffival
 494                                               (list 'ffi-create-fo
 495                                                     ''unsigned-int
 496                                                     (cdr rescell))))
 497                                   (list 'put 'ffival ''value (cdr rescell))
 498                                   'ffival)))
 499                        result))))
 500
 501         ;; define the lookup function
 502         (list 'defun name '(symbol)
 503               (format "Lookup the value of SYMBOL in the enumeration `%s'."
 504                       name)
 505               (list 'cdr-safe
 506                     (list 'assq 'symbol
 507                           name)))
 508
 509         ;; define the lookup function for the elisp value
 510         (list 'defun (intern (format "%s-value" name)) '(symbol)
 511               (format (concat "Lookup the elisp value (an integer) of SYMBOL "
 512                               "in the enumeration `%s'.")
 513                       name)
 514               (list 'get (list name 'symbol) ''value))))
 515 (put 'ffi-enum 'lisp-indent-function 'defun)
 516 ;;; example
 517 ;; (ffi-enum example-enum
 518 ;;   ;;"Enum of control commands."
 519 ;;   test_thing = symbol_1
 520 ;;   symbol_0
 521 ;;   symbol_1
 522 ;;   foobbbbar = test_thing
 523 ;;   snaabar = foobbbbar
 524 ;;   go-on-with5 = 5
 525 ;;   guesswhat)
 526 ;; (example-enum-value 'guesswhat)
 527
 528 (defmacro define-ffi-enum (type-name &rest spec)
 529   "Create enumarate type which you can pass to C functions.
 530 For example:
 531   \(define-ffi-enum MyEnum
 532     \(Boris 0\)
 533     Vova
 534     Micha\)"
 535   `(progn
 536      (define-ffi-type ,type-name int)
 537      (let* ((cv 0)
 538             (fev (mapcar #'(lambda (sv)
 539                              (prog1
 540                                  (if (and (listp sv)
 541                                           (symbolp (car sv))
 542                                           (numberp (cadr sv)))
 543                                      (prog1
 544                                          (cons (car sv) (cadr sv))
 545                                        (setq cv (cadr sv)))
 546                                    (cons sv cv))
 547                                (incf cv)))
 548                          '(,@spec))))
 549        (put ',type-name 'ffi-enum-values fev))
 550      ;; Translators
 551      (define-ffi-translator-to-foreign ,type-name
 552        (or (cdr (assq value (get ',type-name 'ffi-enum-values)))
 553            0))
 554      (define-ffi-translator-from-foreign ,type-name
 555        (or (car (find-if #'(lambda (v)
 556                              (= (cdr v) value))
 557                          (get ',type-name 'ffi-enum-values)))
 558            'undefined-enum-value))))
 559
 560 (defun ffi-enum-values (enum-type)
 561   "Return alist for ENUM-TYPE.
 562 Where car is symbol and cdr is the numeric value for it."
 563   (get enum-type 'ffi-enum-values))
 564
 565 ;;; Callbacks
 566 (defmacro define-ffi-callback (sym retype args &rest body)
 567   "Create new callback to be called from C.
 568 Return foreign object that you can pass as callback to some C
 569 function.
 570
 571 For example:
 572
 573 \(define-ffi-callback my-nice-cb int
 574   \(\(proname c-string\) \(event pointer\)\)
 575   \"Print nice message in the minibuffer and return 10000.\"
 576   \(message \"nice message\"\)
 577   10000\)
 578
 579 To get foreign object for this callback function use `ffi-callback-fo'
 580 and pass the name of the callback."
 581   (let ((argnames (mapcar #'first args))
 582         (argtypes (mapcar #'second args)))
 583   `(progn
 584      (defun ,sym ,argnames
 585        ,@body)
 586      (let ((cfo (ffi-make-callback ',sym ',retype ',argtypes 0)))
 587        (put ',sym 'ffi-callback-fo cfo)
 588        cfo))))
 589
 590 (put 'define-ffi-callback 'lisp-indent-function 'defun)
 591
 592 (defmacro ffi-callback-fo (sym)
 593   "Return SYM callback's foreign object."
 594   `(get ,sym 'ffi-callback-fo))
 595
 596 \f
 597 ;; Define some types
 598 (define-ffi-type boolean int)
 599 (define-ffi-translator-to-foreign boolean
 600   (if value 1 0))
 601 (define-ffi-translator-from-foreign boolean
 602   (not (zerop value)))
 603
 604 (define-ffi-type lisp-object pointer)
 605 (define-ffi-translator-to-foreign lisp-object
 606   (ffi-lisp-object-to-pointer value))
 607 (define-ffi-translator-from-foreign lisp-object
 608   (ffi-pointer-to-lisp-object value))
 609
 610 ;; NOTE: use only for return values
 611 (define-ffi-type safe-string pointer)
 612
 613 (define-ffi-type callback pointer)
 614 (define-ffi-translator-to-foreign callback
 615   (ffi-callback-fo value))
 616
 617 \f
 618 ;;; CFFI
 619 (define-ffi-type :byte byte)
 620 (define-ffi-type :unsigned-byte unsigned-byte)
 621 (define-ffi-type :char char)
 622 (define-ffi-type :unsigned-char unsigned-char)
 623 (define-ffi-type :uchar unsigned-char)
 624 (define-ffi-type :short short)
 625 (define-ffi-type :unsigned-short unsigned-short)
 626 (define-ffi-type :ushort unsigned-short)
 627 (define-ffi-type :int int)
 628 (define-ffi-type :unsigned-int unsigned-int)
 629 (define-ffi-type :uint unsigned-int)
 630 (define-ffi-type :long long)
 631 (define-ffi-type :unsigned-long unsigned-long)
 632 (define-ffi-type :ulong unsigned-long)
 633 (define-ffi-type :float float)
 634 (define-ffi-type :double double)
 635 (define-ffi-type :void void)
 636 (define-ffi-type :pointer pointer)
 637 (define-ffi-type :boolean boolean)
 638 (define-ffi-type :string c-string)
 639
 640 ;;;# Accessing Foreign Globals
 641
 642 (defun cffi:lisp-var-name (name &optional fun-p)
 643   "Return the Lisp symbol for foreign var NAME."
 644   (etypecase name
 645     (list (second name))
 646     (string (intern (format "%s%s%s" (if fun-p "" "*")
 647                             (downcase (substitute ?- ?_ name)) (if fun-p "" "*"))))
 648     (symbol name)))
 649
 650 (defun cffi:foreign-var-name (name)
 651   "Return the foreign var name of NAME."
 652   (etypecase name
 653     (list (first name))
 654     (string name)
 655     (symbol (let ((dname (downcase (symbol-name name))))
 656               (replace-in-string (substitute ?_ ?- dname) "\\*" "")))))
 657
 658 (defun cffi:get-var-pointer (symbol)
 659   "Return a pointer to the foreign global variable relative to SYMBOL."
 660   (cffi:foreign-symbol-pointer (get symbol 'foreign-var-name)))
 661
 662 (defmacro cffi:defcstruct (name &rest args)
 663   `(define-ffi-struct ,name ,@args))
 664
 665 (defmacro cffi:defcvar (name type)
 666   (let ((ns (cffi:lisp-var-name name)))
 667     `(defvar ,ns (ffi-bind ,type (cffi:foreign-var-name ',name)))))
 668
 669 (defmacro cffi:defcfun (name ret-type &optional docstring &rest in-args)
 670   ;; First check if we were passed a docstring
 671   (unless (stringp docstring)
 672     ;; docstring is missing, the value of docstring already contains
 673     ;; the first argument, hence we pump that one to in-args
 674     (unless (null docstring)
 675       (setq in-args (cons docstring in-args)))
 676     (setq docstring
 677           (format "Lisp variant for `%s' foreign function."
 678                   (cffi:foreign-var-name name))))
 679
 680   (let* ((nsl (cffi:lisp-var-name name t))
 681          (nsf (cffi:foreign-var-name name))
 682          (with-rest (when (eq (car (last in-args)) '&rest)
 683                       (setq in-args (butlast in-args))
 684                       t))
 685          (as (mapcar 'first in-args))
 686          (at (mapcar 'second in-args))
 687          (flet-form) (defun-form nil))
 688     (setq flet-form
 689           (append (list `(mapcar* #'setarg ',at (list ,@as)))
 690                   (when with-rest
 691                     (list '(while rest-args
 692                              (if (ffi-object-p (car rest-args))
 693                                  (progn
 694                                    (setarg (ffi-object-type (car rest-args))
 695                                            (car rest-args))
 696                                    (setq rest-args (cdr rest-args)))
 697                              (setarg (car rest-args) (cadr rest-args))
 698                              (setq rest-args (cddr rest-args))))))
 699                   (list '(setq ffiargs (nreverse ffiargs)))
 700                   (list `(setq ret (apply #'ffi-call-function
 701                                           (get ',nsl 'ffi-fun) ffiargs)))
 702                   (list `(ffi-get ret :from-call t))))
 703     (setq defun-form
 704           (append `(defun ,nsl)
 705                   (list (if with-rest
 706                             (append as '(&rest rest-args))
 707                           as))
 708                   (list docstring)
 709                   (list (append
 710                          '(let (ffiargs ret))
 711                          (list (append
 712                                 '(flet ((setarg (type arg)
 713                                           (setq ffiargs
 714                                                 (cons
 715                                                  (if (ffi-object-p arg)
 716                                                      arg
 717                                                    (ffi-create-fo type arg))
 718                                                  ffiargs)))))
 719                                 flet-form))
 720                          ))))
 721     (append '(progn) (list defun-form)
 722             (list `(put ',nsl 'ffi-fun
 723                         (ffi-defun '(function ,ret-type ,@at) ,nsf))))))
 724
 725 (put 'cffi:defcfun 'lisp-indent-function 'defun)
 726
 727 (defun ffi:canonicalize-symbol-name-case (name)
 728   (upcase name))
 729
 730 ;;;# Allocation
 731
 732 (defun cffi:foreign-alloc (type)
 733   "Return pointer."
 734   (ffi-call-function
 735    (ffi-defun '(function pointer unsigned-int) "malloc")
 736    (ffi-create-fo 'unsigned-int (ffi-size-of-type type))))
 737
 738 (defun cffi:foreign-free (ptr)
 739   "Frees a PTR previously allocated with `cffi:foreign-alloc'."
 740   (ffi-call-function
 741    (ffi-defun '(function void pointer) "free")
 742    ptr))
 743
 744 (defmacro cffi:with-foreign-pointer (spec &rest body)
 745   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 746 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 747 may be stack-allocated if supported by the implementation.  If
 748 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 749   (let ((var (car spec))
 750         (size (cadr spec))
 751         (size-var (caddr spec)))
 752     (unless size-var
 753       (setf size-var (gensym "SIZE")))
 754     `(let* ((,size-var ,size)
 755             (,var (cffi:foreign-alloc ,size-var)))
 756        (unwind-protect
 757            (progn ,@body)
 758          (cffi:foreign-free ,var)))))
 759
 760 ;;;# Misc. Pointer Operations
 761
 762 (defun ffi-pointer-p (fo)
 763   "Return non-nil if ffi objct FO has pointer type."
 764   (let ((ctype (ffi-canonicalise-type (ffi-object-type fo))))
 765     (or (eq ctype 'pointer)
 766         (and (listp ctype)
 767              (eq (car ctype) 'pointer)
 768              (ffi-type-p (cadr ctype))))))
 769
 770 (defalias 'cffi:make-pointer 'ffi-make-pointer)
 771 (defalias 'ffi-pointer-address 'ffi-object-address)
 772 (defalias 'cffi:pointer-address 'ffi-pointer-address)
 773 (defalias 'cffi:pointerp 'ffi-pointer-p)
 774 (defalias 'cffi:null-pointer 'ffi-null-pointer)
 775 (defalias 'cffi:null-pointer-p 'ffi-null-p)
 776
 777 (defun cffi:inc-pointer (ptr offset)
 778   "Return a pointer OFFSET bytes past PTR."
 779   (ffi-make-pointer (+ (ffi-object-address ptr) offset)))
 780
 781 (defun cffi:pointer-eq (ptr1 ptr2)
 782   "Return true if PTR1 and PTR2 point to the same address."
 783   (= (ffi-object-address ptr1) (ffi-object-address ptr2)))
 784
 785 ;;;# Dereferencing
 786
 787 (defun* cffi:mem-ref (ptr type &optional (offset 0))
 788   "Dereference an object of TYPE at OFFSET bytes from PTR."
 789   (ffi-fetch ptr offset type))
 790
 791 ; (defun cffi:%mem-set (value ptr type &optional (offset 0))
 792 ;   "Set an object of TYPE at OFFSET bytes from PTR."
 793 ;   (let* ((type (convert-foreign-type type))
 794 ;          (type-size (ffi:size-of-foreign-type type)))
 795 ;     (si:foreign-data-set-elt
 796 ;      (si:foreign-data-recast ptr (+ offset type-size) :void)
 797 ;      offset type value)))
 798
 799 ;;;# Type Operations
 800
 801 (defalias 'cffi:foreign-type-size 'ffi-size-of-type)
 802 (defalias 'cffi:foreign-type-alignment 'ffi-type-alignment)
 803
 804 (defalias 'cffi:load-foreign-library 'ffi-load)
 805
 806 ;;;# Callbacks
 807 (defmacro cffi:%defcallback (name rettype arg-names arg-types &rest body)
 808   `(define-ffi-callback ,name ,rettype ,(mapcar* #'list arg-names arg-types)
 809      ,@body))
 810
 811 (put 'cffi:%defcallback 'lisp-indent-function 'defun)
 812
 813 (defmacro cffi:%callback (name)
 814   `(ffi-callback-fo ,name))
 815
 816 ;;;# Foreign Globals
 817
 818 (defun cffi:foreign-symbol-pointer (name)
 819   "Returns a pointer to a foreign symbol NAME."
 820   (ffi-bind 'pointer name))
 821
 822 ;;;# Finalizers
 823
 824 (defun cffi:finalize (object function)
 825   (error "SXEmacs FFI does not support finalizers."))
 826
 827 (defun cffi:cancel-finalization (object)
 828   (error "SXEmacs FFI does not support finalizers."))
 829
 830 (provide 'ffi)
 831
 832 ;;; ffi.el ends here