external/cffi.darcs/_darcs/pristine/src/foreign-vars.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; foreign-vars.lisp --- High-level interface to foreign globals.
   4 ;;;
   5 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira(@)common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi)
  29
  30 ;;;# Accessing Foreign Globals
  31
  32 ;;; Called by FOREIGN-OPTIONS in functions.lisp.
  33 (defun parse-defcvar-options (options)
  34   (destructuring-bind (&key (library :default) read-only) options
  35     (list :library library :read-only read-only)))
  36
  37 (defun get-var-pointer (symbol)
  38   "Return a pointer to the foreign global variable relative to SYMBOL."
  39   (foreign-symbol-pointer (get symbol 'foreign-var-name)
  40                           :library (get symbol 'foreign-var-library)))
  41
  42 ;;; Note: this will lookup not only variables but also functions.
  43 (defun foreign-symbol-pointer (name &key (library :default))
  44   (%foreign-symbol-pointer
  45    name (if (eq library :default)
  46             :default
  47             (foreign-library-handle
  48              (get-foreign-library library)))))
  49
  50 (defun fs-pointer-or-lose (foreign-name library)
  51   "Like foreign-symbol-ptr but throws an error instead of
  52 returning nil when foreign-name is not found."
  53   (or (foreign-symbol-pointer foreign-name :library library)
  54       (error "Trying to access undefined foreign variable ~S." foreign-name)))
  55
  56 (defmacro defcvar (name-and-options type &optional documentation)
  57   "Define a foreign global variable."
  58   (declare (ignore documentation))
  59   (multiple-value-bind (lisp-name foreign-name options)
  60       (parse-name-and-options name-and-options t)
  61     (let ((fn (symbolicate '#:%var-accessor- lisp-name))
  62           (read-only (getf options :read-only))
  63           (library (getf options :library)))
  64       ;; We can't really setf an aggregate type.
  65       (when (aggregatep (parse-type type))
  66         (setq read-only t))
  67       `(progn
  68          ;; Save foreign-name and library for posterior access by
  69          ;; GET-VAR-POINTER.
  70          (setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
  71          (setf (get ',lisp-name 'foreign-var-library) ',library)
  72          ;; Getter
  73          (defun ,fn ()
  74            (mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type))
  75          ;; Setter
  76          (defun (setf ,fn) (value)
  77            ,(if read-only '(declare (ignore value)) (values))
  78            ,(if read-only
  79                 `(error ,(format nil "Trying to modify read-only foreign var: ~A."
  80                                  lisp-name))
  81                 `(setf (mem-ref (fs-pointer-or-lose ,foreign-name ',library)
  82                                 ',type)
  83                        value)))
  84          ;; While most Lisps already expand DEFINE-SYMBOL-MACRO to an
  85          ;; EVAL-WHEN form like this, that is not required by the
  86          ;; standard so we do it ourselves.
  87          (eval-when (:compile-toplevel :load-toplevel :execute)
  88            (define-symbol-macro ,lisp-name (,fn)))))))