cffi-clasp.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-clasp.lisp (6322B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-clasp.lisp --- CFFI-SYS implementation for Clasp. | |
4 ;;; | |
5 ;;; Copyright (C) 2017 Frank Goenninger <[email protected]… | |
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 ;;;# Administrivia | |
29 | |
30 (defpackage #:cffi-sys | |
31 (:use #:common-lisp #:alexandria) | |
32 (:export | |
33 #:canonicalize-symbol-name-case | |
34 #:foreign-pointer | |
35 #:pointerp | |
36 #:pointer-eq | |
37 #:%foreign-alloc | |
38 #:foreign-free | |
39 #:with-foreign-pointer | |
40 #:null-pointer | |
41 #:null-pointer-p | |
42 #:inc-pointer | |
43 #:make-pointer | |
44 #:pointer-address | |
45 #:%mem-ref | |
46 #:%mem-set | |
47 #:%foreign-funcall | |
48 #:%foreign-funcall-pointer | |
49 #:%foreign-type-alignment | |
50 #:%foreign-type-size | |
51 #:%load-foreign-library | |
52 #:%close-foreign-library | |
53 #:native-namestring | |
54 #:make-shareable-byte-vector | |
55 #:with-pointer-to-vector-data | |
56 #:%defcallback | |
57 #:%callback | |
58 #:%foreign-symbol-pointer)) | |
59 | |
60 (in-package #:cffi-sys) | |
61 | |
62 ;;;# Mis-features | |
63 | |
64 (pushnew 'flat-namespace cl:*features*) | |
65 | |
66 ;;;# Symbol Case | |
67 | |
68 (defun canonicalize-symbol-name-case (name) | |
69 (declare (string name)) | |
70 (string-upcase name)) | |
71 | |
72 ;;;# Allocation | |
73 | |
74 (defun %foreign-alloc (size) | |
75 "Allocate SIZE bytes of foreign-addressable memory." | |
76 (clasp-ffi:%foreign-alloc size)) | |
77 | |
78 (defun foreign-free (ptr) | |
79 "Free a pointer PTR allocated by FOREIGN-ALLOC." | |
80 (clasp-ffi:%foreign-free ptr)) | |
81 | |
82 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
83 "Bind VAR to SIZE bytes of foreign memory during BODY. The | |
84 pointer in VAR is invalid beyond the dynamic extent of BODY, and | |
85 may be stack-allocated if supported by the implementation. If | |
86 SIZE-VAR is supplied, it will be bound to SIZE during BODY." | |
87 (unless size-var | |
88 (setf size-var (gensym "SIZE"))) | |
89 `(let* ((,size-var ,size) | |
90 (,var (%foreign-alloc ,size-var))) | |
91 (unwind-protect | |
92 (progn ,@body) | |
93 (foreign-free ,var)))) | |
94 | |
95 ;;;# Misc. Pointer Operations | |
96 | |
97 (deftype foreign-pointer () | |
98 'clasp-ffi:foreign-data) | |
99 | |
100 (defun null-pointer-p (ptr) | |
101 "Test if PTR is a null pointer." | |
102 (clasp-ffi:%null-pointer-p ptr)) | |
103 | |
104 (defun null-pointer () | |
105 "Construct and return a null pointer." | |
106 (clasp-ffi:%make-nullpointer)) | |
107 | |
108 (defun make-pointer (address) | |
109 "Return a pointer pointing to ADDRESS." | |
110 (clasp-ffi:%make-pointer address)) | |
111 | |
112 (defun inc-pointer (ptr offset) | |
113 "Return a pointer OFFSET bytes past PTR." | |
114 (clasp-ffi:%inc-pointer ptr offset)) | |
115 | |
116 (defun pointer-address (ptr) | |
117 "Return the address pointed to by PTR." | |
118 (clasp-ffi:%foreign-data-address ptr)) | |
119 | |
120 (defun pointerp (ptr) | |
121 "Return true if PTR is a foreign pointer." | |
122 (typep ptr 'clasp-ffi:foreign-data)) | |
123 | |
124 (defun pointer-eq (ptr1 ptr2) | |
125 "Return true if PTR1 and PTR2 point to the same address." | |
126 (check-type ptr1 clasp-ffi:foreign-data) | |
127 (check-type ptr2 clasp-ffi:foreign-data) | |
128 (eql (pointer-address ptr1) (pointer-address ptr2))) | |
129 | |
130 | |
131 ;;;# Shareable Vectors | |
132 ;;; | |
133 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA | |
134 ;;; should be defined to perform a copy-in/copy-out if the Lisp | |
135 ;;; implementation can't do this. | |
136 | |
137 (defun make-shareable-byte-vector (size) | |
138 "Create a Lisp vector of SIZE bytes that can passed to | |
139 WITH-POINTER-TO-VECTOR-DATA." | |
140 (make-array size :element-type '(unsigned-byte 8))) | |
141 | |
142 ;; frgo, 2016-07-02: TODO: Implemenent! | |
143 ;; (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
144 ;; "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
145 ;; `(let ((,ptr-var (si:make-foreign-data-from-array ,vector))) | |
146 ;; ,@body)) | |
147 | |
148 (defun %foreign-type-size (type-keyword) | |
149 "Return the size in bytes of a foreign type." | |
150 (clasp-ffi:%foreign-type-size type-keyword)) | |
151 | |
152 (defun %foreign-type-alignment (type-keyword) | |
153 "Return the alignment in bytes of a foreign type." | |
154 (clasp-ffi:%foreign-type-alignment type-keyword)) | |
155 | |
156 ;;;# Dereferencing | |
157 | |
158 (defun %mem-ref (ptr type &optional (offset 0)) | |
159 "Dereference an object of TYPE at OFFSET bytes from PTR." | |
160 (clasp-ffi:%mem-ref ptr type offset)) | |
161 | |
162 (defun %mem-set (value ptr type &optional (offset 0)) | |
163 "Set an object of TYPE at OFFSET bytes from PTR." | |
164 (clasp-ffi:%mem-set ptr type value offset)) | |
165 | |
166 (defmacro %foreign-funcall (name args &key library convention) | |
167 "Call a foreign function." | |
168 (declare (ignore library convention)) | |
169 `(clasp-ffi:%foreign-funcall ,name ,@args)) | |
170 | |
171 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
172 "Funcall a pointer to a foreign function." | |
173 (declare (ignore convention)) | |
174 `(clasp-ffi:%foreign-funcall-pointer ,ptr ,@args)) | |
175 | |
176 ;;;# Foreign Libraries | |
177 | |
178 (defun %load-foreign-library (name path) | |
179 "Load a foreign library." | |
180 (clasp-ffi:%load-foreign-library name path)) | |
181 | |
182 (defun %close-foreign-library (handle) | |
183 "Close a foreign library." | |
184 (clasp-ffi:%close-foreign-library handle)) | |
185 | |
186 (defun %foreign-symbol-pointer (name library) | |
187 "Returns a pointer to a foreign symbol NAME." | |
188 (clasp-ffi:%foreign-symbol-pointer name library)) | |
189 | |
190 (defun native-namestring (pathname) | |
191 (namestring pathname)) | |
192 | |
193 ;;;# Callbacks | |
194 | |
195 (defmacro %defcallback (name rettype arg-names arg-types body | |
196 &key convention) | |
197 `(clasp-ffi:%defcallback (,name ,@(when convention `(:convention ,conv… | |
198 ,rettype ,arg-names ,arg-types ,body)) | |
199 | |
200 (defun %callback (name) | |
201 (clasp-ffi:%get-callback name)) |