Coverage report: /home/luis/src/cffi/src/foreign-vars.lisp

KindCoveredAll%
expression5356 94.6
branch34 75.0
Key
Not instrumented
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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)))))))
89