structures.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 | |
--- | |
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 <[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 (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)… | |
62 do | |
63 ;; Free if the pointer is to a specific type, not generic… | |
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 i… | |
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-stru… | |
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… | |
84 ;; The body | |
85 (declare (ignorable type)) ; I can't think of a reason why you'd … | |
86 ,@body))) | |
87 | |
88 (defmacro translation-forms-for-class (class type-class) | |
89 "Make forms for translation of foreign structures to and from a standa… | |
90 ;; Possible improvement: optional argument to map structure 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 ,ty… | |
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 def… | |
105 ;;; (translation-forms-for-class class type-class) | |
106 ;;; to connnect the two. It would be nice to have a macro to do all thr… | |
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… | |
112 "Define the functions necessary to convert to and from a foreign struc… | |
113 `(flet ((map-slots (fn val) | |
114 (maphash | |
115 (lambda (name slot-struct) | |
116 (funcall fn (foreign-slot-value val ',type name) (slot-ty… | |
117 (slots (follow-typedefs (parse-type ',type)))))) | |
118 ;; Convert this to a separate function so it doesn't have to be rec… | |
119 (defmethod translate-to-foreign ((,value-symbol ,lisp-class) (type … | |
120 (let ((p (foreign-alloc ',struct-name))) | |
121 ;;(map-slots #'translate-to-foreign ,value-symbol) ; recursive … | |
122 (with-foreign-slots (,slot-names p ,struct-name) | |
123 ,to-form) | |
124 (values p t))) ; second value is passed to FREE-TRANSLATED-OBJE… | |
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 s… | |
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 |# |