Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/foreign-vars.lisp

KindCoveredAll%
expression1167 16.4
branch14 25.0
Key
Not instrumented
Conditionalized out
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-2008, 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
   (check-type name string)
45
   (%foreign-symbol-pointer
46
    name (if (eq library :default)
47
             :default
48
             (foreign-library-handle
49
              (get-foreign-library library)))))
50
 
51
 (defun fs-pointer-or-lose (foreign-name library)
52
   "Like foreign-symbol-ptr but throws an error instead of
53
 returning nil when foreign-name is not found."
54
   (or (foreign-symbol-pointer foreign-name :library library)
55
       (error "Trying to access undefined foreign variable ~S." foreign-name)))
56
 
57
 (defmacro defcvar (name-and-options type &optional documentation)
58
   "Define a foreign global variable."
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
          (setf (documentation ',lisp-name 'variable) ,documentation)
69
          ;; Save foreign-name and library for posterior access by
70
          ;; GET-VAR-POINTER.
71
          (setf (get ',lisp-name 'foreign-var-name) ,foreign-name)
72
          (setf (get ',lisp-name 'foreign-var-library) ',library)
73
          ;; Getter
74
          (defun ,fn ()
75
            (mem-ref (fs-pointer-or-lose ,foreign-name ',library) ',type))
76
          ;; Setter
77
          (defun (setf ,fn) (value)
78
            ,(if read-only '(declare (ignore value)) (values))
79
            ,(if read-only
80
                 `(error ,(format nil
81
                                  "Trying to modify read-only foreign var: ~A."
82
                                  lisp-name))
83
                 `(setf (mem-ref (fs-pointer-or-lose ,foreign-name ',library)
84
                                 ',type)
85
                        value)))
86
          ;; While most Lisps already expand DEFINE-SYMBOL-MACRO to an
87
          ;; EVAL-WHEN form like this, that is not required by the
88
          ;; standard so we do it ourselves.
89
          (eval-when (:compile-toplevel :load-toplevel :execute)
90
            (define-symbol-macro ,lisp-name (,fn)))))))