type-descriptors.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
---
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 structure-type)
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 unknown to libffi."
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) ',slot) ,value)))
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 libffi. This will be used as a cached static read-only argument when the actual call happens.")
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, enum, etc)
106 (make-libffi-type-descriptor (actual-type type))))