type-descriptors.lisp - clic - Clic is an command line interactive client for g… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
type-descriptors.lisp (4698B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; type-descriptors.lisp --- Build malloc'd libffi type descriptors | |
4 ;;; | |
5 ;;; Copyright (C) 2009, 2011 Liam M. Healy | |
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 (defmacro type-descriptor-ptr (type) | |
31 `(foreign-symbol-pointer ,(format nil "ffi_type_~(~A~)" type))) | |
32 | |
33 (defmacro type-descriptor-ptr/integer (type) | |
34 `(foreign-symbol-pointer | |
35 ,(format nil "ffi_type_~Aint~D" | |
36 (if (string-equal type "unsigned" | |
37 :end1 (min 8 (length (string type)))) | |
38 "u" "s") | |
39 (* 8 (foreign-type-size type))))) | |
40 | |
41 (defun %make-libffi-type-descriptor/struct (type) | |
42 (labels | |
43 ((slot-multiplicity (slot) | |
44 (if (typep slot 'aggregate-struct-slot) | |
45 (slot-count slot) | |
46 1)) | |
47 (number-of-items (structure-type) | |
48 "Total number of items in the foreign structure." | |
49 (loop for val being the hash-value of (structure-slots structur… | |
50 sum (slot-multiplicity val)))) | |
51 (let* ((ptr (foreign-alloc '(:struct ffi-type))) | |
52 (nitems (number-of-items type)) | |
53 (type-pointer-array | |
54 (foreign-alloc :pointer :count (1+ nitems)))) | |
55 (loop for slot in (slots-in-order type) | |
56 for ltp = (make-libffi-type-descriptor | |
57 (parse-type (slot-type slot))) | |
58 with slot-counter = 0 | |
59 do (if ltp | |
60 (loop | |
61 repeat (slot-multiplicity slot) | |
62 do (setf | |
63 (mem-aref | |
64 type-pointer-array :pointer slot-counter) | |
65 ltp) | |
66 (incf slot-counter)) | |
67 (libffi-error nil | |
68 "Slot type ~A in foreign structure is u… | |
69 (unparse-type (slot-type slot))))) | |
70 (setf (mem-aref type-pointer-array :pointer nitems) | |
71 (null-pointer)) | |
72 (macrolet ((store (slot value) | |
73 `(setf (foreign-slot-value ptr '(:struct ffi-type) ',… | |
74 (store size 0) | |
75 (store alignment 0) | |
76 (store type +type-struct+) | |
77 (store elements type-pointer-array)) | |
78 ptr))) | |
79 | |
80 (defgeneric make-libffi-type-descriptor (object) | |
81 (:documentation "Build a libffi struct that describes the type for lib… | |
82 (:method ((object foreign-built-in-type)) | |
83 (let ((type-keyword (type-keyword object))) | |
84 #.`(case type-keyword | |
85 ,@(loop | |
86 :for type :in (append *built-in-float-types* | |
87 *other-builtin-types*) | |
88 :collect `(,type (type-descriptor-ptr ,type))) | |
89 ,@(loop | |
90 :for type :in *built-in-integer-types* | |
91 :collect `(,type (type-descriptor-ptr/integer ,type))) | |
92 ;; there's a generic error report in an :around method | |
93 ))) | |
94 (:method ((type foreign-pointer-type)) | |
95 ;; simplify all pointer types into a void* | |
96 (type-descriptor-ptr :pointer)) | |
97 (:method ((type foreign-struct-type)) | |
98 (%make-libffi-type-descriptor/struct type)) | |
99 (:method :around (object) | |
100 (let ((result (call-next-method))) | |
101 (assert result () "~S failed on ~S. That's bad." | |
102 'make-libffi-type-descriptor object) | |
103 result)) | |
104 (:method ((type foreign-type-alias)) | |
105 ;; Set the type pointer on demand for alias types (e.g. typedef, enu… | |
106 (make-libffi-type-descriptor (actual-type type)))) |