cffi-gcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
cffi-gcl.lisp (10297B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; cffi-gcl.lisp --- CFFI-SYS implementation for GNU Common Lisp.
4 ;;;
5 ;;; Copyright (C) 2005-2006, 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 ;;; GCL specific notes:
29 ;;;
30 ;;; On ELF systems, a library can be loaded with the help of this:
31 ;;; http://www.copyleft.de/lisp/gcl-elf-loader.html
32 ;;;
33 ;;; Another way is to link the library when creating a new image:
34 ;;; (compiler::link nil "new_image" "" "-lfoo")
35 ;;;
36 ;;; As GCL's FFI is not dynamic, CFFI declarations will only work
37 ;;; after compiled and loaded.
38
39 ;;; *** this port is broken ***
40 ;;; gcl doesn't compile the rest of CFFI anyway..
41
42 ;;;# Administrivia
43
44 (defpackage #:cffi-sys
45 (:use #:common-lisp #:alexandria)
46 (:export
47 #:canonicalize-symbol-name-case
48 #:pointerp
49 #:%foreign-alloc
50 #:foreign-free
51 #:with-foreign-ptr
52 #:null-ptr
53 #:null-ptr-p
54 #:inc-ptr
55 #:%mem-ref
56 #:%mem-set
57 #:%foreign-funcall
58 #:%foreign-type-alignment
59 #:%foreign-type-size
60 #:%load-foreign-library
61 ;#:make-shareable-byte-vector
62 ;#:with-pointer-to-vector-data
63 #:foreign-var-ptr
64 #:make-callback))
65
66 (in-package #:cffi-sys)
67
68 ;;;# Mis-*features*
69 (eval-when (:compile-toplevel :load-toplevel :execute)
70 (pushnew :cffi/no-foreign-funcall *features*))
71
72 ;;; Symbol case.
73
74 (defun canonicalize-symbol-name-case (name)
75 (declare (string name))
76 (string-upcase name))
77
78 ;;;# Allocation
79 ;;;
80 ;;; Functions and macros for allocating foreign memory on the stack
81 ;;; and on the heap. The main CFFI package defines macros that wrap
82 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
83 ;;; usage when the memory has dynamic extent.
84
85 (defentry %foreign-alloc (int) (int "malloc"))
86
87 ;(defun foreign-alloc (size)
88 ; "Allocate SIZE bytes on the heap and return a pointer."
89 ; (%foreign-alloc size))
90
91 (defentry foreign-free (int) (void "free"))
92
93 ;(defun foreign-free (ptr)
94 ; "Free a PTR allocated by FOREIGN-ALLOC."
95 ; (%free ptr))
96
97 (defmacro with-foreign-ptr ((var size &optional size-var) &body body)
98 "Bind VAR to SIZE bytes of foreign memory during BODY. The
99 pointer in VAR is invalid beyond the dynamic extent of BODY, and
100 may be stack-allocated if supported by the implementation. If
101 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
102 (unless size-var
103 (setf size-var (gensym "SIZE")))
104 `(let* ((,size-var ,size)
105 (,var (foreign-alloc ,size-var)))
106 (unwind-protect
107 (progn ,@body)
108 (foreign-free ,var))))
109
110 ;;;# Misc. Pointer Operations
111
112 (defun pointerp (ptr)
113 "Return true if PTR is a foreign pointer."
114 (integerp ptr))
115
116 (defun null-ptr ()
117 "Construct and return a null pointer."
118 0)
119
120 (defun null-ptr-p (ptr)
121 "Return true if PTR is a null pointer."
122 (= ptr 0))
123
124 (defun inc-ptr (ptr offset)
125 "Return a pointer OFFSET bytes past PTR."
126 (+ ptr offset))
127
128 ;;;# Shareable Vectors
129 ;;;
130 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
131 ;;; should be defined to perform a copy-in/copy-out if the Lisp
132 ;;; implementation can't do this.
133
134 ;(defun make-shareable-byte-vector (size)
135 ; "Create a Lisp vector of SIZE bytes that can passed to
136 ;WITH-POINTER-TO-VECTOR-DATA."
137 ; (make-array size :element-type '(unsigned-byte 8)))
138
139 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
140 ; "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
141 ; `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
142 ; ,@body))
143
144 ;;;# Dereferencing
145
146 (defmacro define-mem-ref/set (type gcl-type &optional c-name)
147 (unless c-name
148 (setq c-name (substitute #\_ #\Space type)))
149 (let ((ref-fn (concatenate 'string "ref_" c-name))
150 (set-fn (concatenate 'string "set_" c-name)))
151 `(progn
152 ;; ref
153 (defcfun ,(format nil "~A ~A(~A *ptr)" type ref-fn type)
154 0 "return *ptr;")
155 (defentry ,(intern (string-upcase (substitute #\- #\_ ref-fn)))
156 (int) (,gcl-type ,ref-fn))
157 ;; set
158 (defcfun ,(format nil "void ~A(~A *ptr, ~A value)" set-fn type type)
159 0 "*ptr = value;")
160 (defentry ,(intern (string-upcase (substitute #\- #\_ set-fn)))
161 (int ,gcl-type) (void ,set-fn)))))
162
163 (define-mem-ref/set "char" char)
164 (define-mem-ref/set "unsigned char" char)
165 (define-mem-ref/set "short" int)
166 (define-mem-ref/set "unsigned short" int)
167 (define-mem-ref/set "int" int)
168 (define-mem-ref/set "unsigned int" int)
169 (define-mem-ref/set "long" int)
170 (define-mem-ref/set "unsigned long" int)
171 (define-mem-ref/set "float" float)
172 (define-mem-ref/set "double" double)
173 (define-mem-ref/set "void *" int "ptr")
174
175 (defun %mem-ref (ptr type &optional (offset 0))
176 "Dereference an object of TYPE at OFFSET bytes from PTR."
177 (unless (zerop offset)
178 (incf ptr offset))
179 (ecase type
180 (:char (ref-char ptr))
181 (:unsigned-char (ref-unsigned-char ptr))
182 (:short (ref-short ptr))
183 (:unsigned-short (ref-unsigned-short ptr))
184 (:int (ref-int ptr))
185 (:unsigned-int (ref-unsigned-int ptr))
186 (:long (ref-long ptr))
187 (:unsigned-long (ref-unsigned-long ptr))
188 (:float (ref-float ptr))
189 (:double (ref-double ptr))
190 (:pointer (ref-ptr ptr))))
191
192 (defun %mem-set (value ptr type &optional (offset 0))
193 (unless (zerop offset)
194 (incf ptr offset))
195 (ecase type
196 (:char (set-char ptr value))
197 (:unsigned-char (set-unsigned-char ptr value))
198 (:short (set-short ptr value))
199 (:unsigned-short (set-unsigned-short ptr value))
200 (:int (set-int ptr value))
201 (:unsigned-int (set-unsigned-int ptr value))
202 (:long (set-long ptr value))
203 (:unsigned-long (set-unsigned-long ptr value))
204 (:float (set-float ptr value))
205 (:double (set-double ptr value))
206 (:pointer (set-ptr ptr value)))
207 value)
208
209 ;;;# Calling Foreign Functions
210
211 ;; TODO: figure out if these type conversions make any sense...
212 (defun convert-foreign-type (type-keyword)
213 "Convert a CFFI type keyword to a GCL type."
214 (ecase type-keyword
215 (:char 'char)
216 (:unsigned-char 'char)
217 (:short 'int)
218 (:unsigned-short 'int)
219 (:int 'int)
220 (:unsigned-int 'int)
221 (:long 'int)
222 (:unsigned-long 'int)
223 (:float 'float)
224 (:double 'double)
225 (:pointer 'int)
226 (:void 'void)))
227
228 (defparameter +cffi-types+
229 '(:char :unsigned-char :short :unsigned-short :int :unsigned-int
230 :long :unsigned-long :float :double :pointer))
231
232 (defcfun "int size_of(int type)" 0
233 "switch (type) {
234 case 0: return sizeof(char);
235 case 1: return sizeof(unsigned char);
236 case 2: return sizeof(short);
237 case 3: return sizeof(unsigned short);
238 case 4: return sizeof(int);
239 case 5: return sizeof(unsigned int);
240 case 6: return sizeof(long);
241 case 7: return sizeof(unsigned long);
242 case 8: return sizeof(float);
243 case 9: return sizeof(double);
244 case 10: return sizeof(void *);
245 default: return -1;
246 }")
247
248 (defentry size-of (int) (int "size_of"))
249
250 ;; TODO: all this is doable inside the defcfun; figure that out..
251 (defun %foreign-type-size (type-keyword)
252 "Return the size in bytes of a foreign type."
253 (size-of (position type-keyword +cffi-types+)))
254
255 (defcfun "int align_of(int type)" 0
256 "switch (type) {
257 case 0: return __alignof__(char);
258 case 1: return __alignof__(unsigned char);
259 case 2: return __alignof__(short);
260 case 3: return __alignof__(unsigned short);
261 case 4: return __alignof__(int);
262 case 5: return __alignof__(unsigned int);
263 case 6: return __alignof__(long);
264 case 7: return __alignof__(unsigned long);
265 case 8: return __alignof__(float);
266 case 9: return __alignof__(double);
267 case 10: return __alignof__(void *);
268 default: return -1;
269 }")
270
271 (defentry align-of (int) (int "align_of"))
272
273 ;; TODO: like %foreign-type-size
274 (defun %foreign-type-alignment (type-keyword)
275 "Return the alignment in bytes of a foreign type."
276 (align-of (position type-keyword +cffi-types+)))
277
278 #+ignore
279 (defun convert-external-name (name)
280 "Add an underscore to NAME if necessary for the ABI."
281 #+darwinppc-target (concatenate 'string "_" name)
282 #-darwinppc-target name)
283
284 (defmacro %foreign-funcall (function-name &rest args)
285 "Perform a foreign function all, document it more later."
286 `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
287
288 (defun defcfun-helper-forms (name rettype args types)
289 "Return 2 values for DEFCFUN. A prelude form and a caller form."
290 (let ((ff-name (intern (format nil "%foreign-function/TildeA:~A" name))))
291 (values
292 `(defentry ,ff-name ,(mapcar #'convert-foreign-type types)
293 (,(convert-foreign-type rettype) ,name))
294 `(,ff-name ,@args))))
295
296 ;;;# Callbacks
297
298 ;;; XXX unimplemented
299 (defmacro make-callback (name rettype arg-names arg-types body-form)
300 0)
301
302 ;;;# Loading Foreign Libraries
303
304 (defun %load-foreign-library (name)
305 "_Won't_ load the foreign library NAME."
306 (declare (ignore name)))
307
308 ;;;# Foreign Globals
309
310 ;;; XXX unimplemented
311 (defmacro foreign-var-ptr (name)
312 "Return a pointer pointing to the foreign symbol NAME."
313 0)