structures.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
---
structures.lisp (6764B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; structures.lisp --- Methods for translating foreign structures.
4 ;;;
5 ;;; Copyright (C) 2011, Liam M. Healy <lhealy@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 ;;; Definitions for conversion of foreign structures.
31
32 (defmethod translate-into-foreign-memory ((object list)
33 (type foreign-struct-type)
34 p)
35 (unless (bare-struct-type-p type)
36 (loop for (name value) on object by #'cddr
37 do (setf (foreign-slot-value p (unparse-type type) name)
38 (let ((slot (gethash name (structure-slots type))))
39 (convert-to-foreign value (slot-type slot)))))))
40
41 (defmethod translate-to-foreign (value (type foreign-struct-type))
42 (let ((ptr (foreign-alloc type)))
43 (translate-into-foreign-memory value type ptr)
44 ptr))
45
46 (defmethod translate-from-foreign (p (type foreign-struct-type))
47 ;; Iterate over slots, make plist
48 (if (bare-struct-type-p type)
49 p
50 (let ((plist (list)))
51 (loop for slot being the hash-value of (structure-slots type)
52 for name = (slot-name slot)
53 do (setf (getf plist name)
54 (foreign-struct-slot-value p slot)))
55 plist)))
56
57 (defmethod free-translated-object (ptr (type foreign-struct-type) freep)
58 (unless (bare-struct-type-p type)
59 ;; Look for any pointer slots and free them first
60 (loop for slot being the hash-value of (structure-slots type)
61 when (and (listp (slot-type slot)) (eq (first (slot-type slot)) :pointer))
62 do
63 ;; Free if the pointer is to a specific type, not generic :pointer
64 (free-translated-object
65 (foreign-slot-value ptr type (slot-name slot))
66 (rest (slot-type slot))
67 freep))
68 (foreign-free ptr)))
69
70 (defmacro define-translation-method ((object type method) &body body)
71 "Define a translation method for the foreign structure type; 'method is one of :into, :from, or :to, meaning relation to foreign memory. If :into, the variable 'pointer is the foreign pointer. Note: type must be defined and loaded before this macro is expanded, and just the bare name (without :struct) should be specified."
72 (let ((tclass (class-name (class-of (cffi::parse-type `(:struct ,type))))))
73 (when (eq tclass 'foreign-struct-type)
74 (error "Won't replace existing translation method for foreign-struct-type"))
75 `(defmethod
76 ,(case method
77 (:into 'translate-into-foreign-memory)
78 (:from 'translate-from-foreign)
79 (:to 'translate-to-foreign))
80 ;; Arguments to the method
81 (,object
82 (type ,tclass)
83 ,@(when (eq method :into) '(pointer))) ; is intentional variable capture a good idea?
84 ;; The body
85 (declare (ignorable type)) ; I can't think of a reason why you'd want to use this
86 ,@body)))
87
88 (defmacro translation-forms-for-class (class type-class)
89 "Make forms for translation of foreign structures to and from a standard class. The class slots are assumed to have the same name as the foreign structure."
90 ;; Possible improvement: optional argument to map structure slot names to/from class slot names.
91 `(progn
92 (defmethod translate-from-foreign (pointer (type ,type-class))
93 ;; Make the instance from the plist
94 (apply 'make-instance ',class (call-next-method)))
95 (defmethod translate-into-foreign-memory ((object ,class) (type ,type-class) pointer)
96 (call-next-method
97 ;; Translate into a plist and call the general method
98 (loop for slot being the hash-value of (structure-slots type)
99 for name = (slot-name slot)
100 append (list slot-name (slot-value object slot-name)))
101 type
102 pointer))))
103
104 ;;; For a class already defined and loaded, and a defcstruct already defined, use
105 ;;; (translation-forms-for-class class type-class)
106 ;;; to connnect the two. It would be nice to have a macro to do all three simultaneously.
107 ;;; (defmacro define-foreign-structure (class ))
108
109 #|
110 (defmacro define-structure-conversion
111 (value-symbol type lisp-class slot-names to-form from-form &optional (struct-name type))
112 "Define the functions necessary to convert to and from a foreign structure. The to-form sets each of the foreign slots in succession, assume the foreign object exists. The from-form creates the Lisp object, making it with the correct value by reference to foreign slots."
113 `(flet ((map-slots (fn val)
114 (maphash
115 (lambda (name slot-struct)
116 (funcall fn (foreign-slot-value val ',type name) (slot-type slot-struct)))
117 (slots (follow-typedefs (parse-type ',type))))))
118 ;; Convert this to a separate function so it doesn't have to be recomputed on the fly each time.
119 (defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type ,type))
120 (let ((p (foreign-alloc ',struct-name)))
121 ;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive translation of slots
122 (with-foreign-slots (,slot-names p ,struct-name)
123 ,to-form)
124 (values p t))) ; second value is passed to FREE-TRANSLATED-OBJECT
125 (defmethod free-translated-object (,value-symbol (p ,type) freep)
126 (when freep
127 ;; Is this redundant?
128 (map-slots #'free-translated-object value) ; recursively free slots
129 (foreign-free ,value-symbol)))
130 (defmethod translate-from-foreign (,value-symbol (type ,type))
131 (with-foreign-slots (,slot-names ,value-symbol ,struct-name)
132 ,from-form))))
133 |#